From: drewc Date: Sat, 19 Jan 2008 06:32:46 +0000 (-0800) Subject: simplified slot access somewhat. layered slots still a little screwy. X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/commitdiff_plain/81d7061052c90867a26b50e69e35f5d96b17686a?hp=f2ff8a16385c1c4bc677c703a0b48d0255046456 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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))))))