From eeed4326c3330d13ba9f8b8b06254d7a370a5d85 Mon Sep 17 00:00:00 2001 From: drewc Date: Sun, 20 Dec 2009 14:46:10 -0800 Subject: [PATCH] Initial commit of new description code (warning: broken!) darcs-hash:20091220224610-39164-6fd7ad22b7ab93057d5488350240d5622852d7a8.gz --- lisp-on-lines.asd | 25 +++-- src/attribute-test.lisp | 54 +++++----- src/display.lisp | 5 +- src/new-description.lisp | 127 +++++++++--------------- src/packages.lisp | 4 + src/standard-descriptions/clos.lisp | 30 +++--- src/standard-descriptions/edit.lisp | 17 ++-- src/standard-descriptions/list.lisp | 2 +- src/standard-descriptions/null.lisp | 2 +- src/standard-descriptions/validate.lisp | 5 +- src/ucw/html-description.lisp | 39 ++++---- 11 files changed, 151 insertions(+), 159 deletions(-) diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd index 04a4d55..591a728 100644 --- a/lisp-on-lines.asd +++ b/lisp-on-lines.asd @@ -38,21 +38,30 @@ OTHER DEALINGS IN THE SOFTWARE." :components ((:static-file "lisp-on-lines.asd") (:module :src - :components ((:file "contextl-hacks") + :components (#-lol-mao(:file "contextl-hacks") (:file "packages") (:file "utilities") - (:file "display") - (:file "attribute") - - (:file "description-class") - (:file "description") - - + #+lol-mao + (:module :mao + :components ((:file "simple-plist-attribute") + (:file "attribute") + (:file "description-class") + (:file "description") + (:module :display + :components ((:file "display-attribute") + (:file "display-description") + (:file "define-description-compat")) + :serial t)) + :serial t) + (:file "display") + #-lol-mao(:file "attribute") + #-lol-mao(:file "description-class") + #-lol-mao(:file "description") (:module :standard-descriptions :components ((:file "t") diff --git a/src/attribute-test.lisp b/src/attribute-test.lisp index 74caa00..a092a78 100644 --- a/src/attribute-test.lisp +++ b/src/attribute-test.lisp @@ -9,52 +9,58 @@ ((attribute-1 :value "VALUE") (attribute-2 :function (constantly "VALUE")))) - (deflayer attribute-test) + (define-description attribute-test) (define-description attribute-test-description () ((attribute-1 :value "VALUE2") (attribute-2 :function (constantly "VALUE2"))) - (: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 (find-attribute d 'attribute-1)) - (attribute-value (find-attribute d 'attribute-2)))) - (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1)))))))) + (:in-description attribute-test)))) + + (funcall-with-described-object + (lambda (&aux + (a1 (find-attribute *description* 'attribute-1)) + (a2 (find-attribute *description* 'attribute-2)) + ) + (is (equalp "VALUE" (attribute-value a1))) + (is (equalp "VALUE" (attribute-value a2))) + (with-active-descriptions (attribute-test) + (is (equalp "VALUE2" (attribute-value a1))) + (is (equalp "VALUE2" (attribute-value a2))))) + nil + (find-description 'attribute-test-description))) (deftest test-attribute-property-inheriting () (test-attribute-value) (eval '(progn - (deflayer attribute-property-test) + (define-description attribute-property-test) (define-description attribute-test-description () ((attribute-1 :label "attribute1") (attribute-2 :label "attribute2")) - (: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))) + (:in-description attribute-property-test)))) + + (with-active-descriptions (attribute-property-test) + (with-described-object (nil (find-description 'attribute-test-description)) + (let ((d (dynamic description))) + (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)))) - (with-active-layers (attribute-test) + (with-active-descriptions (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))))))))) + (is (equalp "VALUE2" (attribute-value (find-attribute d 'attribute-1))))))) +)) (deftest (test-attribute-with-different-class :compile-before-run t) () (eval '(progn (define-layered-class - test-attribute-class (lol::standard-attribute) - ((some-slot :initarg :some-slot - :layered t - :layered-accessor some-slot))) + test-attribute-class (standard-attribute) + ((some-slot :initarg :some-slot + :layered t + :special 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/display.lisp b/src/display.lisp index 6078e83..d04a131 100644 --- a/src/display.lisp +++ b/src/display.lisp @@ -39,7 +39,7 @@ (apply #'display-using-description (description-of object) display object args)))) (define-layered-method display-using-description - :around (description display object &rest args) + :around ((description standard-description-object) display object &rest args) (declare (ignorable args)) #+nil (break "Entering DISPLAY for ~A on ~A using ~A" object display description) (let ((*display* display)) @@ -50,6 +50,7 @@ + (defun display/d (&rest args) (apply #'display-using-description args)) @@ -80,7 +81,7 @@ OMGWTF! If you didn't do this, it's a bug!" description display object args)) (list (first description-spec) (if (eq 'description (second description-spec)) 'description - (defining-description (second description-spec))))) + (contextl::defining-layer (defining-description (second description-spec)))))) ,display-spec ,object-spec &rest args) (declare (ignorable args)) diff --git a/src/new-description.lisp b/src/new-description.lisp index 673e7ef..1475ef7 100644 --- a/src/new-description.lisp +++ b/src/new-description.lisp @@ -1,10 +1,13 @@ (in-package :lisp-on-lines) +;;;; A simpler implementation of descriptions based on plists + (setf (find-class 'simple-attribute nil) nil) (define-layered-class simple-attribute () ((%property-access-function - :initarg property-access-function))) + :initarg property-access-function) + (%initial-slot-values-plist))) (defun ensure-property-access-function (attribute) (if (slot-boundp attribute '%property-access-function) @@ -17,9 +20,7 @@ (define-layered-method contextl:slot-value-using-layer (class (attribute simple-attribute) slotd reader) - (if (or *symbol-access* - (eq (slot-definition-name slotd) - '%property-access-function) + (if (or contextl:*symbol-access* (not (slot-definition-layeredp slotd))) (call-next-method) (let ((value (getf (funcall (ensure-property-access-function attribute)) @@ -29,82 +30,50 @@ (call-next-method) value)))) -(defvar *test-attribute-definitions* - `((t :label "foo" :value "foo") - (simple-test-layer :label "BAZ" :value "BAZ"))) +(define-layered-method + contextl:slot-value-using-layer (class (attribute simple-attribute) slotd reader) + (if (or contextl:*symbol-access* + (not (slot-definition-layeredp slotd)) + (dynamic-symbol-boundp (with-symbol-access (call-next-method)))) + (call-next-method) + (let ((value (getf (ignore-errors (funcall (ensure-property-access-function attribute))) + (slot-definition-name slotd) + +property-not-found+))) + (if (eq value +property-not-found+) + (let ((value (get (ensure-property-access-function attribute) + (slot-definition-name slotd) + +property-not-found+))) + (if (eq value +property-not-found+) + (call-next-method) + value)) + value)))) + +(define-layered-method + (setf contextl:slot-value-using-layer) (value class (attribute simple-attribute) slotd reader) + (if (and (not contextl:*symbol-access*) + (slot-definition-layeredp slotd)) + (setf (get (ensure-property-access-function attribute) (slot-definition-name slotd)) + value) + (call-next-method))) (defmethod initialize-attribute-for-layer (attribute layer-name &rest args) (let* ((class (class-of attribute)) - (slotds (class-slots class))) - + (slotds (class-slots class))) (ensure-layered-method (ensure-property-access-function attribute) `(lambda () ',(loop - :for (key val) :on args :by #'cddr - :nconc (list - (loop :for slotd :in slotds - :do (when (find key (slot-definition-initargs slotd)) - (return (slot-definition-name slotd)))) - val))) + :for (key val) :on args :by #'cddr + :nconc (list + (loop + :for slotd :in slotds + :do (when (find key (slot-definition-initargs slotd)) + (return (slot-definition-name slotd)))) + val))) :qualifiers '(append) :in-layer layer-name))) - -(define-layered-class simple-standard-attribute (simple-attribute) - ((label - :layered-accessor attribute-label - :initarg :label - :initform nil - :layered t - :special t) - (label-formatter - :layered-accessor attribute-label-formatter - :initarg :label-formatter - :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) - (value-formatter - :layered-accessor attribute-value-formatter - :initarg :value-formatter - :initform nil - :layered t - :special t) - (activep - :layered-accessor attribute-active-p - :initarg :active - :initform t - :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.") - (active-attributes :layered-accessor attribute-active-attributes - :initarg :attributes - :layered t - :special t) - (active-descriptions :layered-accessor attribute-active-descriptions - :initarg :activate - :initform nil - :layered t - :special t) - (inactive-descriptions :layered-accessor attribute-inactive-descriptions - :initarg :deactivate - :initform nil - :layered t - :special t))) - - (define-layered-class direct-attribute-slot-definition-class (special-layered-direct-slot-definition contextl::singleton-direct-slot-definition) @@ -140,10 +109,12 @@ ((class description-access-class) &key &allow-other-keys) (find-class 'effective-attribute-slot-definition-class)) (fmakunbound 'initialize-slot-definition-attribute) + (defmethod initialize-slot-definition-attribute ((slotd effective-attribute-slot-definition-class) name direct-slot-definitions) (let ((tbl (make-hash-table)) (attribute (make-instance 'simple-standard-attribute :name name))) - (loop for ds in direct-slot-definitions + (loop for ds in direct-slot-definitions + :when (typep ds 'direct-attribute-slot-definition-class) :do (setf (gethash (slot-definition-layer ds) tbl) (append (gethash (slot-definition-layer ds) tbl '()) (slot-definition-attribute-properties ds)))) @@ -156,7 +127,7 @@ ((class description-access-class) name direct-slot-definitions) (declare (ignore name)) (let ((slotd (call-next-method))) - (initialize-slot-definition-attribute slotd) + (initialize-slot-definition-attribute slotd name direct-slot-definitions) slotd)) (defclass standard-description-class (description-access-class layered-class) @@ -172,9 +143,6 @@ ((described-object :accessor described-object :special t))) -(defun initialize-description-class-attribute (description attribute initargs) - ) - (defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '())) (declare (dynamic-extent initargs)) (prog1 @@ -186,8 +154,7 @@ :direct-superclasses (append direct-superclasses (list (find-class 'standard-description-object))) - initargs)) - (break "initializing ~A ~A" class initargs))) + initargs)))) (defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p)) @@ -203,13 +170,11 @@ :direct-superclasses (append direct-superclasses (list (find-class 'standard-description-object))) - initargs)) - (break "RE-initializing ~A ~A" class initargs))) + initargs)))) + + -(defmethod finalize-inheritance :after ((class standard-description-class)) - (break "Finalizing ~S" (class-name class))) -;;;; A simpler implementation of descriptions based on plists diff --git a/src/packages.lisp b/src/packages.lisp index 07ff448..475fbdb 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -11,12 +11,16 @@ ;; Descriptions #:*description* + #:description + #:defdescription #:find-description + #:current-description #:description-of #:define-description #:defining-description #:described-object #:with-described-object + #:funcall-with-described-object #:described-class #:described-standard-class #:with-active-descriptions diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp index 4bb7abe..377380d 100644 --- a/src/standard-descriptions/clos.lisp +++ b/src/standard-descriptions/clos.lisp @@ -13,7 +13,13 @@ (class-slots :label "Slots" :function (compose 'class-slots 'class-of)))) -(define-layered-class slot-definition-attribute (standard-attribute) +(define-description standard-object () + ((editp :value t) + (class-slots :label "Slots" + :function (compose 'class-slots 'class-of))) + (:in-description editable)) + +(define-layered-class slot-definition-attribute (define-description-attribute) ((slot-name :initarg :slot-name :accessor attribute-slot-name :layered t))) @@ -38,11 +44,12 @@ (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)))))) + (with-active-descriptions (editable) + (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-using-object (object (attribute slot-definition-attribute)) @@ -62,7 +69,7 @@ (delete nil (mapcar (rcurry #'find-description nil) (mapcar #'class-name direct-superclasses))))) (desc-class - (ensure-class (defining-description name) + (ensure-layer (defining-description name) :direct-superclasses (or super-descriptions (list (class-of (find-description 'standard-object)))) :direct-slots (loop @@ -97,12 +104,11 @@ :finally (return (cons `(:name active-attributes :value ',(or attributes names)) slots))) - :metaclass 'standard-description-class))) + :metaclass 'define-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))) + (find-layer (ensure-layer (defining-description (class-name class)) + :direct-superclasses (list desc-class) + :metaclass 'define-description-class))))) (defclass described-class () diff --git a/src/standard-descriptions/edit.lisp b/src/standard-descriptions/edit.lisp index f1ec4cf..9993080 100644 --- a/src/standard-descriptions/edit.lisp +++ b/src/standard-descriptions/edit.lisp @@ -4,18 +4,19 @@ () (:mixinp t)) -(define-layered-class standard-attribute +(define-layered-class define-description-attribute :in-layer #.(defining-description 'editable) () ((edit-attribute-p :initform :inherit :layered-accessor attribute-editp :initarg :editp - :layered t) + :layered t + :special t) (setter :initarg :setter :layered t - :accessor attribute-setter + :layered-accessor attribute-setter :initform nil) (attribute-editor :initarg :editor @@ -24,6 +25,9 @@ :initform (make-instance 'attribute-editor) :documentation "This ones a bit odd"))) +(define-layered-method attribute-setter (object) + nil) + (defmethod shared-initialize :after ((object standard-attribute) slots &rest args &key input &allow-other-keys) @@ -114,12 +118,13 @@ :in-layer #.(defining-description 'editable) ((attribute standard-attribute)) (let ((value (attribute-value attribute))) - (unless (or (unbound-slot-value-p value) - (typep value + (unless (or (unbound-slot-value-p value) + (typep value (attribute-editor-type (attribute-editor attribute)))) - (return-from attribute-editp nil))) + (return-from attribute-editp nil))) (let ((edit? (call-next-method))) + (if (eq :inherit edit?) (attribute-value (find-attribute (attribute-description attribute) diff --git a/src/standard-descriptions/list.lisp b/src/standard-descriptions/list.lisp index 0beb994..33e9ca2 100644 --- a/src/standard-descriptions/list.lisp +++ b/src/standard-descriptions/list.lisp @@ -1,7 +1,7 @@ (in-package :lisp-on-lines) -(define-layered-class list-attribute (standard-attribute) +(define-layered-class list-attribute (define-description-attribute) ((item-args :initform nil :initarg :item :layered t :special t))) (define-layered-method display-attribute-value diff --git a/src/standard-descriptions/null.lisp b/src/standard-descriptions/null.lisp index 8c9161a..cafaed5 100644 --- a/src/standard-descriptions/null.lisp +++ b/src/standard-descriptions/null.lisp @@ -4,4 +4,4 @@ ()) (define-layered-method description-of ((object null)) - (find-description 'null)) \ No newline at end of file + (find-description 'null)) diff --git a/src/standard-descriptions/validate.lisp b/src/standard-descriptions/validate.lisp index 6bfeaeb..3f423e8 100644 --- a/src/standard-descriptions/validate.lisp +++ b/src/standard-descriptions/validate.lisp @@ -1,8 +1,7 @@ (in-package :lisp-on-lines) -(defclass #.(defining-description 'validate) () - ((invalid-object-condition-map :layered t :special t )) - (:metaclass standard-description-class)) +(define-description validate () + ((invalid-object-condition-map :layered t :special t ))) (define-layered-class standard-attribute :in-layer #.(defining-description 'validate) diff --git a/src/ucw/html-description.lisp b/src/ucw/html-description.lisp index 94a8add..4905c65 100644 --- a/src/ucw/html-description.lisp +++ b/src/ucw/html-description.lisp @@ -88,7 +88,7 @@ (define-layered-method display-using-description :in-layer #.(defining-description 'html-description) :around ((attribute standard-attribute) display object &rest args) - (declare (ignore args)) + (declare (ignore args)) (display-html-attribute object attribute)) @@ -99,15 +99,17 @@ (apply function args))))) (defun make-attribute-value-writer (attribute) - (let ((obj (described-object (attribute-description attribute))) - (value (attribute-value attribute))) + (let ((obj (described-object (attribute-description attribute))) + (value (attribute-value attribute)) + (desc (attribute-description attribute))) (lambda (val) - (dletf (((described-object attribute) obj)) + (dletf (((described-object (attribute-description attribute)) obj)) (with-active-descriptions (editable) (unless (and (unbound-slot-value-p value) (equal "" val)) - (setf (attribute-value attribute) - (parse-attribute-value attribute val)))))))) + (with-described-object (obj desc) + (setf (attribute-value attribute) + (parse-attribute-value attribute val))))))))) (defmethod html-attribute-value (attribute) @@ -129,9 +131,6 @@ :reader (html-attribute-value attribute) :writer (make-attribute-value-writer attribute))) - - - (define-layered-method display-attribute-editor :in-layer #.(defining-description 'html-description) (attribute) (display-html-attribute-editor attribute (attribute-editor attribute))) @@ -140,20 +139,17 @@ (define-layered-method display-html-attribute-value :in-layer #.(defining-description 'editable) (object attribute) - + (<:as-html (princ-to-string (attribute-editp attribute))) (if (attribute-editp attribute) (<:td - :class "lol-attribute-value"(display-attribute-editor attribute)) + :class "lol-attribute-value" (display-attribute-editor attribute)) (call-next-method))) (define-layered-function display-html-description (description display object &optional next-method) (:method (description display object &optional (next-method #'display-using-description)) - - - (with-attributes (css-class dom-id) description - - - (<:table + (let ((dom-id (find-attribute description 'dom-id)) + (css-class (find-attribute description 'dom-id))) + (<:table :class (list (attribute-value css-class) "lol-description" "t") :id (attribute-value dom-id) (funcall next-method) @@ -162,11 +158,12 @@ (define-layered-method display-html-description :in-layer #.(defining-description 'inline) (description display object &optional next-method) - (with-attributes (css-class dom-id) description + (let ((dom-id (find-attribute description 'dom-id)) + (css-class (find-attribute description 'dom-id))) (<:span - :class (list (attribute-value css-class) "lol-description") - :id (attribute-value dom-id) - (funcall next-method)))) + :class (list (attribute-value css-class) "lol-description") + :id (attribute-value dom-id) + (funcall next-method)))) (define-display -- 2.20.1