X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/88670beca060fc94190b30d4dc6ccb38dbe2fbcd..1d51a2eea8537084e9e681c297422047ae858989:/src/mewa.lisp diff --git a/src/mewa.lisp b/src/mewa.lisp index 24aa788..ca40f24 100644 --- a/src/mewa.lisp +++ b/src/mewa.lisp @@ -1,111 +1,23 @@ (in-package :lisp-on-lines) -(defun persistentp (object) - (slot-value object 'clsql-sys::view-database)) - -(define-layered-class description () - ((description-type - :initarg :type - :accessor description-type - :initform 'viewer - :special t) - (description-layers - :initarg :layers - :accessor description-layers - :initform nil - :special t) - (described-object - :layered-accessor object - :initform nil - :special t) - (description-default-attributes - :accessor default-attributes - :initarg :default-attributes - :initform nil - :special t) - (description-attributes - :accessor attributes - :initarg :attributes - :initform nil - :special t) - (description-properties - :accessor description-properties - :initarg :properties - :initform '() - :special t) - (description-default-properties - :accessor default-properties - :initarg :default-properties - :initform '() - :special t))) - -(defmethod attributes :around ((description description)) - "Add any default properties to the attributes" - - (let ((default-properties (default-properties description))) (if (and (listp default-properties) - (not (null default-properties))) - (let ((a (mapcar #'(lambda (att) - (append (ensure-list att) default-properties)) - (call-next-method)))) - - - a) - (call-next-method)))) - -(defmethod print-object ((self description) stream) - (print-unreadable-object (self stream :type t) - (with-slots (description-type) self - (format stream "~A" description-type)))) - ;;;; * Occurences +;;;; Occurences can be thought of as the class of a description. +;;;; Most of the occurence stuff is depreciated now. -(defvar *occurence-map* (make-hash-table) - "a display is generated by associating an 'occurence' -with an instance of a class. This is usually keyed off class-name, -although an arbitrary occurence could be used with an arbitrary class.") - -(define-layered-class - standard-occurence (description) - ((occurence-name :accessor name :initarg :name) - (attribute-map :accessor attribute-map :initform (make-hash-table))) - (:documentation "an occurence holds the attributes like a class holds slot-definitions. -Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects.")) +Attributes are the yetadata used to display, validate, and otherwise manipulate actual values stored in lisp objects." (defun find-or-create-occurence (name) "Returns the occurence associated with this name." - (or (get-occurence name) - (values (setf (get-occurence name) (make-instance 'standard-occurence :name name)) - t))) - -(defun get-occurence (name) - (gethash name *occurence-map*)) - -(defun (setf get-occurence) (occurence name) - (setf (gethash name *occurence-map*) occurence)) + (let ((description (find-description name))) + (if description + (class-of description) + (class-of (ensure-description name))))) (defun clear-occurence (occurence) "removes all attributes from the occurence" (setf (attribute-map occurence) (make-hash-table))) -(defmethod make-attribute-using-slot-definition (slotd) - (make-attribute - :name (closer-mop:slot-definition-name slotd) - :type-spec (closer-mop:slot-definition-type slotd) - :type (first (remove-if (lambda (item) - (or - (eql item 'or) - (eql item 'null) - (eql item nil))) - (ensure-list (closer-mop:slot-definition-type slotd)))))) - -(defmethod initialize-occurence-for-instance (occurence instance) - (let ((slots (closer-mop:class-slots (class-of instance)))) - (dolist (s slots) - (let ((att (make-attribute-using-slot-definition s))) - (setf (find-attribute occurence (attribute-name att)) att))) - occurence)) - (defgeneric find-occurence (name) (:method (thing) nil) @@ -127,6 +39,29 @@ Attributes are the metadata used to display, validate, and otherwise manipulate res)) +(defmethod make-attribute-using-slot-definition (slotd) + (make-attribute + :name (closer-mop:slot-definition-name slotd) + :type-spec (closer-mop:slot-definition-type slotd) + :type (first (remove-if (lambda (item) + (or + (eql item 'or) + (eql item 'null) + (eql item nil))) + (ensure-list (closer-mop:slot-definition-type slotd)))))) + +(defmethod initialize-occurence-for-instance (occurence instance) + (let ((slots (closer-mop:class-slots (class-of instance)))) + (dolist (s slots) + (let ((att (make-attribute-using-slot-definition s))) + (setf (find-attribute occurence (attribute-name att)) att))) + occurence)) + + + + +;;;; * Attributes + (define-layered-class attribute (description) ((attribute-name :layered-accessor attribute-name @@ -137,7 +72,6 @@ Attributes are the metadata used to display, validate, and otherwise manipulate (label :initarg :label :layered-accessor label :initform nil :special t))) -;;;; * Attributes (defmethod print-object ((self attribute) stream) (print-unreadable-object (self stream :type t) (with-slots (attribute-name description-type) self @@ -200,7 +134,7 @@ Attributes are the metadata used to display, validate, and otherwise manipulate :properties args args)) -(defmethod ensure-attribute ((occurence standard-occurence) &rest args &key name &allow-other-keys) +(defmethod ensure-attribute ((occurence description) &rest args &key name &allow-other-keys) "Creates an attribute in the given occurence" (let ((attribute (apply #'make-attribute :occurence occurence args))) (setf (find-attribute occurence name) attribute))) @@ -208,7 +142,7 @@ Attributes are the metadata used to display, validate, and otherwise manipulate (defmethod find-attribute ((occurence null) name) nil) -(defmethod find-attribute ((occurence standard-occurence) name) +(defmethod find-attribute ((occurence description) name) (or (gethash name (attribute-map occurence)) (let* ((class (ignore-errors (find-class (name occurence)))) (class-direct-superclasses @@ -224,7 +158,7 @@ Attributes are the metadata used to display, validate, and otherwise manipulate name))) attribute))))) -(defmethod find-all-attributes ((occurence standard-occurence)) +(defmethod find-all-attributes ((occurence description)) (loop for att being the hash-values of (attribute-map occurence) collect att)) @@ -309,9 +243,7 @@ otherwise, (setf find-attribute)" collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions))))) -(defmethod find-description (object type) - (let ((occurence (find-occurence object))) - occurence)) + ;;"Unused???" (defmethod setter (attribute)