X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/6de8d30004efc9337b8c40d2ff2d0a76651d23eb..ddf67d6be45e1ea2d58aef8cceeba26f73ed1a0c:/src/standard-descriptions/clos.lisp diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp index 8531b22..f1465a1 100644 --- a/src/standard-descriptions/clos.lisp +++ b/src/standard-descriptions/clos.lisp @@ -13,72 +13,153 @@ (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-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))) + + +(define-layered-method attribute-active-p :around ((attribute slot-definition-attribute)) + (let ((active? (slot-value attribute 'activep))) + (if (and (eq :when active?) + (unbound-slot-value-p (attribute-value attribute))) + NIL + + (call-next-method)))) + +(define-layered-method attribute-active-p + :in-layer #.(defining-description 'editable) + :around ((attribute slot-definition-attribute)) + (let ((active? (slot-value attribute 'activep))) + (if (and (eq :when active?) + (unbound-slot-value-p (attribute-value attribute))) + t + (call-next-method)))) (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) + (if (unbound-slot-value-p v) + (slot-makunbound o (attribute-slot-name object)) + (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)) - (gensym "UNBOUND-SLOT-"))) - -(defun ensure-description-for-class (class &optional (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class))))) - (let ((desc-class - (ensure-class (defining-description name) - :direct-superclasses (list (class-of (find-description 'standard-object))) - :direct-slots (loop :for slot in (class-slots class) - :collect `(:name ,(slot-definition-name slot) - :attribute-class slot-definition-attribute - :slot-name ,(slot-definition-name slot) - :label ,(slot-definition-name slot)) - :into slots + +unbound-slot+)) + +(defun attribute-slot-makunbound (attribute) + (slot-makunbound (attribute-object attribute) (attribute-slot-name attribute))) + +(defun ensure-description-for-class (class &key attributes (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class)))) + direct-superclasses direct-slot-specs) + + (let* ((super-descriptions + (mapcar #'class-of + (delete nil (mapcar (rcurry #'find-description nil) + (mapcar #'class-name direct-superclasses))))) + (desc-class + (ensure-layer (defining-description name) + :direct-superclasses (or super-descriptions (list (class-of (find-description 'standard-object)))) + :direct-slots + (loop + :for slot in (class-slots class) + :collect + (let ((direct-spec + (find (slot-definition-name slot) + direct-slot-specs + :key (rcurry 'getf :name)))) + (if direct-spec + (append (alexandria:remove-from-plist direct-spec + :initfunction + :initform + :initargs + :readers + :writers) + (unless + (getf direct-spec :attribute-class) + (list :attribute-class 'slot-definition-attribute)) + (unless + (getf direct-spec :label) + (list :label (format nil + "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot)))))) + (list :slot-name (slot-definition-name slot))) + `(:name ,(slot-definition-name slot) + :attribute-class slot-definition-attribute + :slot-name ,(slot-definition-name slot) + :label ,(format nil + "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot))))))) + :into slots :collect (slot-definition-name slot) :into names :finally (return (cons `(:name active-attributes - :value ,names) + :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 () + ((direct-slot-specs :accessor class-direct-slot-specs) + (attributes :initarg :attributes :initform nil))) + +(defmethod ensure-class-using-class :around ((class described-class) name &rest args) + + (call-next-method)) + +(defmethod direct-slot-definition-class ((class described-class) &rest initargs) + (let ((slot-class (call-next-method))) + (make-instance (class-of slot-class) :direct-superclasses (list slot-class (find-class 'described-class-direct-slot-definition))))) + +(defclass described-class-direct-slot-definition () ()) +(defmethod shared-initialize :around ((class described-class-direct-slot-definition) slot-names &key &allow-other-keys) + (call-next-method)) + (defmethod validate-superclass ((class described-class) (superclass standard-class)) t) -(defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '())) +(defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots) (declare (dynamic-extent initargs)) (finalize-inheritance class) - (ensure-description-for-class class)) - + (ensure-description-for-class class :direct-slot-specs direct-slots + :direct-superclasses direct-superclasses + :attributes (slot-value class 'attributes))) -(defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p)) +(defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots) (declare (dynamic-extent initargs)) (finalize-inheritance class) - (ensure-description-for-class class)) + (ensure-description-for-class class :direct-slot-specs direct-slots + :direct-superclasses direct-superclasses + :attributes (slot-value class 'attributes))) +(defclass described-standard-class (described-class standard-class ) ()) + +(defmethod validate-superclass + ((class described-standard-class) + (superclass standard-class)) + t) - - (define-layered-method description-of ((object standard-object)) (or (ignore-errors (find-description (class-name (class-of object)))) (find-description 'standard-object))) - - - + +