API CHANGE: Removed the OBJECT arg from attribute-value

ATTRIBUTE-VALUE now only takes the attribute. The rest of the arguments
it really needs are now set up in the dynamic environment.

You can still specialize ATTRIBUTE-VALUE-USING-OBJECT.

This should be the last API change for a while. The tests have been
modified to reflect the change.

darcs-hash:20080222203147-39164-73b7e3e69c71891123efbb3f78b2250541823d6b.gz

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

diff --git a/src/attribute-test.lisp b/src/attribute-test.lisp
index 279151f..0cff6eb 100644 (file)
--- a/src/attribute-test.lisp
+++ b/src/attribute-test.lisp
@@ -17,14 +17,13 @@
        (:in-layer . attribute-test))))
 
   (let ((d (find-description 'attribute-test-description)))
-    
+    (dletf (((described-object d) nil))
     (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
                
-
     (with-active-layers (attribute-test)
-      (is (equalp (attribute-value nil (find-attribute d 'attribute-1))
-                 (attribute-value nil (find-attribute d 'attribute-2))))
-      (is (equalp "VALUE2" (attribute-value nil (find-attribute d 'attribute-1)))))))
+      (is (equalp (attribute-value (find-attribute d 'attribute-1))
+                 (attribute-value (find-attribute d 'attribute-2))))
+      (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1))))))))
 
 (deftest test-attribute-property-inheriting ()
   (test-attribute-value)
@@ -36,17 +35,18 @@
            (:in-layer . attribute-property-test))))
   (with-active-layers (attribute-property-test)
     (let ((d (find-description 'attribute-test-description)))
+      (dletf (((described-object d) nil))
     
-      (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
+       (is (equalp "VALUE" (slot-value (find-attribute d 'attribute-1) 'lol::value)))
 
-      (is (equalp "attribute1" (attribute-label (find-attribute d 'attribute-1))))
-      (is (equalp "attribute2" (attribute-label (find-attribute d 'attribute-2))))
+       (is (equalp "attribute1" (attribute-label (find-attribute d 'attribute-1))))
+       (is (equalp "attribute2" (attribute-label (find-attribute d 'attribute-2))))
                
 
-      (with-active-layers (attribute-test)
-       (is (equalp (attribute-value nil (find-attribute d 'attribute-1))
-                   (attribute-value nil (find-attribute d 'attribute-2))))
-       (is (equalp "VALUE2" (attribute-value nil (find-attribute d 'attribute-1))))))))
+       (with-active-layers (attribute-test)
+         (is (equalp (attribute-value (find-attribute d 'attribute-1))
+                     (attribute-value (find-attribute d 'attribute-2))))
+         (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1)))))))))
 
 (deftest (test-attribute-with-different-class :compile-before-run t) ()
   (eval '(progn 

diff --git a/src/attribute.lisp b/src/attribute.lisp
index 2b66d42..e93ef93 100644 (file)
--- a/src/attribute.lisp
+++ b/src/attribute.lisp
@@ -19,7 +19,7 @@
   ((direct-attributes 
     :accessor attribute-direct-attributes)
    (attribute-object 
-    :accessor attribute-object)
+    :accessor slot-definition-attribute-object)
    (attribute-object-initargs 
     :accessor attribute-object-initargs)))
 
@@ -41,15 +41,25 @@
   (:method  (description attribute-name property-name)
     (ensure-layered-function 
      (defining-description 
-        (intern (format nil "~A-~A-~A" 
+        (intern (format nil "=PROPERTY-ACCESS-FUNCTION-FOR-~A->~A.~A=" 
                         (description-print-name description)
                         attribute-name
                         property-name)))
         :lambda-list '(description))))
 
 
-(define-layered-class standard-attribute ()
- ((description-class :initarg description-class)
+(defvar *init-time-description* nil)
+
+(defmethod attribute-description :around (attribute)
+  (handler-case (call-next-method)
+    (unbound-slot () 
+      (or 
+       *init-time-description*
+q       (call-next-method)))))
+
+(define-layered-class attribute ()
+ ((description :initarg :description 
+              :accessor attribute-description)
   (name 
    :layered-accessor attribute-name 
    :initarg :name)
@@ -61,7 +71,21 @@
    :initarg :attribute-class 
    :initform 'standard-attribute
    :layered t)
-  (label 
+  (keyword
+   :layered-accessor attribute-keyword
+   :initarg :keyword
+   :initform nil
+   :layered t)
+  (object 
+   :layered-accessor attribute-object
+   :accessor described-object
+   :special t)))
+
+
+     
+                        
+(define-layered-class standard-attribute (attribute)
+ ((label 
    :layered-accessor attribute-label 
    :initarg :label
    :initform nil
@@ -73,22 +97,38 @@
    :layered t
    :special t)
    (value 
-    :layered-accessor %attribute-value 
+    :layered-accessor attribute-value 
     :initarg :value
     :layered t
     :special t)
   (activep 
    :layered-accessor attribute-active-p
-   :initarg :activep
+   :initarg :activep ;depreciated
+   :initarg :active
    :initform t
    :layered t
-   :special t)
-  (keyword
-   :layered-accessor attribute-keyword
-   :initarg :keyword
-   :initform nil
-   :layered t)
-))
+   :special t
+   :documentation
+   "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.")))
+
+
+(define-layered-method attribute-object ((attribute standard-attribute))
+ (if (slot-boundp attribute 'object)
+     (call-next-method)
+     (described-object (attribute-description attribute))))
+
+
+(define-layered-method attribute-value ((attribute standard-attribute))
+ (attribute-value-using-object (attribute-object attribute) attribute))
+                      
+(define-layered-function attribute-value-using-object (object attribute))
+
+(define-layered-method attribute-value-using-object (object attribute)
+ (let ((fn (handler-case (attribute-function attribute)
+            (unbound-slot () nil))))
+   (if fn 
+       (funcall fn object)
+       (slot-value attribute 'value))))
 
 (defun ensure-access-function (class attribute property)
   (with-function-access 
@@ -204,22 +244,6 @@
                    
              
 
- (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))))
 
 
 
@@ -249,32 +273,7 @@
 (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/description-class.lisp b/src/description-class.lisp
index 0669167..7e364e3 100644 (file)
--- a/src/description-class.lisp
+++ b/src/description-class.lisp
@@ -54,9 +54,15 @@
          ;; This plist will be used to init the attribute object
           ;; Once the description itself is properly initiated.
          (list :name name 
-               'effective-attribute attribute
-               'description-class class))
+               'effective-attribute attribute))
     attribute))
+
+(defmethod slot-value-using-class ((class description-access-class) object slotd)
+  (if (or 
+       (eq (slot-definition-name slotd) 'described-object)
+       (not (slot-boundp slotd 'attribute-object)))
+      (call-next-method)
+      (slot-definition-attribute-object slotd)))
     
 
 (defclass standard-description-class (description-access-class layered-class)
@@ -68,8 +74,9 @@
             (superclass standard-class))
   t)
 
-(defclass standard-description-object (standard-layer-object) 
-  ())
+(define-layered-class standard-description-object (standard-layer-object) 
+  ((described-object :accessor described-object 
+                    :special t)))
 
 (defun description-class-name  (description-class)
     (read-from-string (symbol-name (class-name description-class))))
@@ -90,11 +97,16 @@
         (attribute-objects 
          (mapcar 
           (lambda (slot)
-            (setf (attribute-object slot)
-                  (apply #'make-instance 
-                         'standard-attribute
-                         (attribute-object-initargs slot))))
-          (class-slots (class-of description))))
+            (let* ((*init-time-description* description)
+                         (attribute                 (apply #'make-instance 
+                           'standard-attribute
+                           :description description
+                           (attribute-object-initargs slot))))
+                    
+                    
+              (setf (slot-definition-attribute-object slot) attribute)))
+          (remove 'described-object (class-slots (class-of description))
+                  :key #'slot-definition-name)))
         (defining-classes (partial-class-defining-classes (class-of description))))
 
     (loop 
@@ -120,8 +132,7 @@
                                  initargs)))
                       
 
-                      (setf (slot-value description (attribute-name attribute))
-                            attribute))))))))
+                      )))))))
 
 ;;;; HACK: run this at startup till we figure things out.
 (defun initialize-descriptions () 

diff --git a/src/description.lisp b/src/description.lisp
index d19b92e..ae5850c 100644 (file)
--- a/src/description.lisp
+++ b/src/description.lisp
@@ -13,11 +13,12 @@
 
 
 (defun description-attributes (description)
-  (mapcar (curry
-          #'slot-value-using-class 
-          (class-of 'description)
-          description) 
-         (class-slots (class-of description))))
+  (let ((class (class-of description)))
+    (loop :for slot :in (class-slots class)
+       :if (and 
+               (not (eq 'described-object 
+                        (slot-definition-name slot))))
+       :collect (slot-definition-attribute-object slot))))
 
 
 
@@ -26,7 +27,7 @@
     (let* ((active-attributes 
            (find-attribute description 'active-attributes))
           (attributes (when active-attributes
-            (attribute-value *object* active-attributes))))
+            (attribute-value active-attributes))))
       (if attributes
          (mapcar (lambda (spec)                    
                    (find-attribute 

diff --git a/src/display.lisp b/src/display.lisp
index 28957a9..f9998a7 100644 (file)
--- a/src/display.lisp
+++ b/src/display.lisp
@@ -21,6 +21,7 @@
   (let ((*description* description)
        (*display* display)
        (*object*  object))
+    (dletf (((described-object description) object))
     (contextl::funcall-with-special-initargs  
       (loop 
         :for (key val) :on args :by #'cddr
@@ -31,14 +32,14 @@
        (contextl::funcall-with-special-initargs  
         (let ((attribute (find-attribute description 'active-attributes)))     
           (when attribute
-            (loop for spec in (attribute-value object 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)))))))
+       (call-next-method))))))))
                              
 
 

diff --git a/src/packages.lisp b/src/packages.lisp
index 2bca20d..b10abdb 100644 (file)
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -12,10 +12,13 @@
    #:standard-db-access-class
    #:make-dao-from-row
    #:described-db-access-class
+   #:select-only
+   #:select
 
 ;; Descriptions
    #:find-description
    #:define-description
+   #:described-object
    #:described-class
    #:with-active-descriptions
 

diff --git a/src/rofl.lisp b/src/rofl.lisp
index 48cc0cc..4982223 100644 (file)
--- a/src/rofl.lisp
+++ b/src/rofl.lisp
@@ -187,6 +187,28 @@ or return nil if it does not exist."
       
       (slot-value-using-class class dao (class-id-slot-definition class)))))
 
+(postmodern::def-row-reader symbol-plist-row-reader (fields)
+
+  (let ((symbols (map 'list (lambda (desc) 
+                  (postmodern::from-sql-name (postmodern::field-name desc))) fields)))
+    (loop :while (postmodern::next-row)
+          :collect (loop :for field :across fields
+                         :for symbol :in symbols
+                         :nconc (list symbol (postmodern::next-field field))))))
+
+
+(setf postmodern::*result-styles* 
+      (nconc (list '(:plists symbol-plist-row-reader nil)
+                  '(:plist symbol-plist-row-reader t))
+            postmodern::*result-styles*))
+
+(defun select (&rest query)
+    (query (sql-compile (cons :select query)) :plists))
+
+(defun select-only (num &rest query)
+  (query (sql-compile `(:limit ,(cons :select query) ,num)) 
+        :plists))
+
 (defun make-dao-from-row (type row &key slots)
   (let* ((class (find-class type))
         (dao (make-instance class))

diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp
index 8531b22..0fc53af 100644 (file)
--- a/src/standard-descriptions/clos.lisp
+++ b/src/standard-descriptions/clos.lisp
@@ -25,7 +25,7 @@
              (setf (slot-value o (attribute-slot-name object)) v))))))
                  
 
-(define-layered-method attribute-value (object (attribute slot-definition-attribute))
+(define-layered-method attribute-value-using-object (object (attribute slot-definition-attribute))
   (if (slot-boundp object (attribute-slot-name attribute))
                       
       (slot-value object (attribute-slot-name attribute))
@@ -53,6 +53,7 @@
                        :metaclass 'standard-description-class))
   (find-description name)))
 
+
 (defclass described-class ()
   ())
 
@@ -73,8 +74,6 @@
   (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)))

diff --git a/src/standard-descriptions/edit.lisp b/src/standard-descriptions/edit.lisp
index 2d8c42c..6786ceb 100644 (file)
--- a/src/standard-descriptions/edit.lisp
+++ b/src/standard-descriptions/edit.lisp
@@ -14,7 +14,7 @@
    (class :editp nil))
   (:in-description editable))
 
-(define-layered-function (setf attribute-value) (v o a)
+#+nil(define-layered-function (setf attribute-value) (v o a)
   (:method (value object attribute)
     (let ((setter (attribute-setter attribute)))
       (if setter
@@ -54,7 +54,9 @@
   ((attribute standard-attribute) display object &rest args)
   
   (declare (ignore args))
-  (format t "Editable? ~A ~A" (attribute-label attribute) (attribute-editp object attribute)))
+  (if (attribute-editp object attribute)
+      (format *display* "This is where we'd edit")
+      (call-next-method)))
 
 
                       
\ No newline at end of file

diff --git a/src/standard-descriptions/t.lisp b/src/standard-descriptions/t.lisp
index 2980e31..eff4d4e 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" :function #'type-of)
+   (type :label "Type of" :function #'type-of)
    (class :label "Class" :function #'class-of)
    (active-attributes :label "Attributes"
                      :value nil
@@ -12,6 +12,29 @@
 (define-layered-method description-of (any-lisp-object)
   (find-description 't))
 
+(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 attribute)))
+      (if (eql 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))
+
 (define-display ((description t))
   (format *display* "~{~A~%~}" 
          (mapcar 

diff --git a/src/ucw/html-description.lisp b/src/ucw/html-description.lisp
index 57c8125..120d317 100644 (file)
--- a/src/ucw/html-description.lisp
+++ b/src/ucw/html-description.lisp
@@ -5,7 +5,6 @@
 (define-description html-description ()
   ())
 
-
 (define-description t ()
   ((css-class  :value "lol-description" :activep nil)
    (dom-id :function (lambda (x)
@@ -39,8 +38,9 @@
   (:method (object attribute)
     (<:span 
        :class "lol-attribute-value"
-       (<:as-html   (with-output-to-string (*display*)
-                (display-attribute-value object attribute))))
+       (<:as-html   
+        (with-output-to-string (*display*)
+          (display-attribute-value object attribute))))
 ))
 
 (define-layered-function display-html-attribute (object attribute)
@@ -127,7 +127,9 @@ clear: left;
   )
 
 (define-display 
-  :in-description html-description ((description t) (display lol-ucw:component) object )
+  :in-description html-description ((description t) 
+                                   (display lol-ucw:component) 
+                                   object)
   (display-html-description description display object))