From e8d4fa4537a1655714ad8bbbf9b7ba2d85ead959 Mon Sep 17 00:00:00 2001 From: drewc Date: Fri, 22 Feb 2008 12:31:47 -0800 Subject: [PATCH] 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 --- lisp-on-lines.asd | 1 + src/attribute-test.lisp | 24 +++--- src/attribute.lisp | 111 ++++++++++++++-------------- src/description-class.lisp | 33 ++++++--- src/description.lisp | 13 ++-- src/display.lisp | 5 +- src/packages.lisp | 3 + src/rofl.lisp | 22 ++++++ src/standard-descriptions/clos.lisp | 5 +- src/standard-descriptions/edit.lisp | 6 +- src/standard-descriptions/t.lisp | 25 ++++++- src/ucw/html-description.lisp | 10 ++- 12 files changed, 161 insertions(+), 97 deletions(-) diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd index bb4117b..a3181f2 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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)) -- 2.20.1