X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/599c2ea6caf671406348215e3242dc7feef13a50..e1645f63189477f1b39a173a41fcbbfefb5e88a6:/src/mewa.lisp?ds=sidebyside diff --git a/src/mewa.lisp b/src/mewa.lisp index c8fe7a5..7c712ef 100644 --- a/src/mewa.lisp +++ b/src/mewa.lisp @@ -4,41 +4,41 @@ (defparameter *default-type* :ucw) -;;;; I think these are unused now -(defmethod perform-set-attributes ((occurence-name t) definitions) - (dolist (def definitions) - (funcall #'set-attribute occurence-name (first def) (rest def)))) - -(defmethod perform-set-attribute-properties ((occurence-name t) definitions) - (dolist (def definitions) - (funcall #'set-attribute-properties occurence-name (car def) (cdr def)))) - -;;;; PLIST Utilities. - -(defun plist-nunion (new-props plist) - "Destructive Merge of plists. PLIST is modified and returned. -NEW-PROPS is merged into PLIST such that any properties -in both PLIST and NEW-PROPS get the value in NEW-PROPS. -The other properties in PLIST are left untouched." - (loop for cons on new-props by #'cddr - do (setf (getf plist (first cons)) (second cons)) - finally (return plist)) - plist) - -(defun plist-union (new-props plist) - "Non-destructive version of plist-nunion" - (plist-nunion new-props (copy-list plist))) +(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) + (description-properties + :accessor description.properties + :initform nil + :special t) + (description-attributes + :accessor attributes + :initarg :attributes + :initform nil + :special t))) +(defmethod print-object ((self description) stream) + (print-unreadable-object (self stream :type t) + (with-slots (description-type) self + (format t "~A" description-type)))) ;;;; * Occurences (defvar *occurence-map* (make-hash-table) - "Presentations are created by associating an 'occurence' + "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 can be used with an arbitrary class.") (define-layered-class - standard-occurence () + standard-occurence (description) ((attribute-map :accessor attribute-map :initform (make-hash-table))) (:documentation "an occurence holds the attributes like a class holds slot-definitions. @@ -66,36 +66,57 @@ Attributes are the metadata used to display, validate, and otherwise manipulate (find-or-create-occurence (class-name (class-of instance))))) +(define-layered-class + attribute (description) + ((name :layered-accessor attribute.name + :initarg :name + :initform (gensym "ATTRIBUTE-") + :special t) + (occurence :accessor occurence :initarg :occurence :initform nil) + (label :initarg :label :accessor label :initform nil :special t))) + ;;;; * Attributes +(defmethod print-object ((self attribute) stream) + (print-unreadable-object (self stream :type t) + (with-slots (name description-type) self + (format stream "~A ~A" description-type name)))) (define-layered-class - standard-attribute () - ((name :layered-accessor attribute.name :initarg :name :initform "attribute") - (type :layered-accessor attribute.type :initarg :type :initform t :type symbol) - (properties :layered-accessor attribute.properties :initarg :properties :initform nil)) + standard-attribute (attribute) + ((setter :accessor setter :initarg :setter :special t :initform nil) + (getter :accessor getter :initarg :getter :special t :initform nil) + (slot-name :accessor slot-name :initarg :slot-name :special t) + (id :accessor id :initarg :id :special t :initform (random-string))) (:documentation "Attributes are used to display a part of a thing, such as a slot of an object, a text label, the car of a list, etc.")) (defmacro defattribute (name supers slots &rest args) (let ((type (or (second (assoc :type-name args)) name)) - (properties (cdr (assoc :default-properties args)))) + (layer (or (second (assoc :in-layer args)) nil)) + (properties (cdr (assoc :default-properties args))) + (cargs (remove-if #'(lambda (key) + (or (eql key :type-name) + (eql key :default-properties) + (eql key :default-initargs) + (eql key :in-layer))) + args + :key #'car))) + `(progn - (define-layered-class ;;;; TODO: fix the naive way of making sure s-a is a superclass - ,name ,(or supers '(standard-attribute)) - ,slots - #+ (or) ,@ (cdr args) - (:default-initargs :properties (list ,@properties))) + ;;;; Need some MOPey goodness. + ,name ,@ (when layer `(:in-layer ,layer)),(or supers '(standard-attribute)) + ,(append slots (properties-as-slots properties)) + #+ (or) ,@ (cdr cargs) + ,@cargs + (:default-initargs :properties (list ,@properties) + ,@ (cdr (assoc :default-initargs args)))) + (defmethod find-attribute-class-for-type ((type (eql ',type))) ',name)))) -(defmethod print-object ((self standard-attribute) stream) - (print-unreadable-object (self stream :type t) - (with-slots (name type) self - (format stream "~A ~A" name type)))) - (define-layered-class - presentation-attribute (standard-attribute) + display-attribute (attribute) () (:documentation "Presentation Attributes are used to display objects using the attributes defined in an occurence. Presentation Attributes are always named using keywords.")) @@ -110,21 +131,21 @@ using the attributes defined in an occurence. Presentation Attributes are always (defmethod find-attribute-class-for-name (name) "presentation attributes are named using keywords" (if (keywordp name) - 'presentation-attribute + 'display-attribute 'standard-attribute)) -(defun make-attribute (&key name type properties) - (let ((i (make-instance (or (find-attribute-class-for-type type) - (find-attribute-class-for-name name)) - :name name :type type))) - (setf (attribute.properties i) - (plist-union properties (attribute.properties i))) - i)) +(defun make-attribute (&rest args &key name type &allow-other-keys) + (apply #'make-instance + (or (find-attribute-class-for-type type) + (find-attribute-class-for-name name)) + args)) -(defmethod ensure-attribute ((occurence standard-occurence) name type properties) +(defmethod ensure-attribute ((occurence standard-occurence) &rest args &key name &allow-other-keys) "Creates an attribute in the given occurence" - (setf (gethash name (attribute-map occurence)) - (make-attribute :name name :type type :properties properties))) + (let ((attribute (apply #'make-attribute :occurence occurence args))) + (setf (description.properties attribute) args) + (setf (gethash name (attribute-map occurence)) + attribute))) (defmethod find-attribute ((occurence standard-occurence) name) (gethash name (attribute-map occurence))) @@ -133,12 +154,11 @@ using the attributes defined in an occurence. Presentation Attributes are always (loop for att being the hash-values of (attribute-map occurence) collect att)) -(defmethod ensure-attribute (occurence-name name type properties) - (ensure-attribute +(defmethod ensure-attribute (occurence-name &rest args &key name type &allow-other-keys) + (declare (ignore name type)) + (apply #'ensure-attribute (find-occurence occurence-name) - name - type - properties)) + args)) ;;;; The following functions make up the public interface to the ;;;; MEWA Attribute Occurence system. @@ -147,48 +167,76 @@ using the attributes defined in an occurence. Presentation Attributes are always (find-all-attributes (find-occurence occurence-name))) (defmethod find-attribute (occurence-name attribute-name) - "Returns the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name" + "Return the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name" (find-attribute (find-occurence occurence-name) attribute-name)) -(defmethod (setf find-attribute) ((def list) occurence-name attribute-name) - (ensure-attribute occurence-name attribute-name (first def) (rest def))) +(defmethod (setf find-attribute) ((attribute-spec list) occurence-name attribute-name) + "Create a new attribute in the occurence. +ATTRIBUTE-SPEC: a list of (type name &rest initargs)" + (apply #'ensure-attribute occurence-name :name attribute-name :type (first attribute-spec) (rest attribute-spec))) -(defmethod set-attribute (occurence-name attribute-name definition &key (inherit t)) - (let ((att (find-attribute occurence-name attribute-name))) - (setf (find-attribute occurence-name attribute-name) - (if (and att inherit) - (cons (car definition) - (plist-union (cdr definition) - (attribute.properties att))) - definition)))) + +(defmethod find-attribute ((attribute-with-occurence attribute) attribute-name) + (find-attribute (occurence attribute-with-occurence) attribute-name)) (defmethod set-attribute-properties ((occurence-name t) attribute properties) - (let ((a (find-attribute occurence-name attribute))) - (if a - (setf (attribute.properties a) (plist-nunion properties (attribute.properties a))) - (error "Attribute ~A does not exist" attribute)))) + (setf (description.properties attribute) (plist-nunion + properties + (description.properties attribute))) + (loop for (initarg value) on (description.properties attribute) + by #'cddr + with map = (initargs.slot-names attribute) + do (let ((s-n (assoc-if #'(lambda (x) (member initarg x)) map))) + + (if s-n + (progn + (setf (slot-value attribute + (cdr s-n)) + value)) + (warn "Cannot find initarg ~A in attribute ~S" initarg attribute))) + finally (return attribute))) + +(defmethod set-attribute (occurence-name attribute-name attribute-spec &key (inherit t)) + "If inherit is T, sets the properties of the attribute only, unless the type has changed. +otherwise, (setf find-attribute)" + (let ((att (find-attribute occurence-name attribute-name))) + (if (and att inherit (or (eql (car attribute-spec) + (description.type att)) + (eq (car attribute-spec) t))) + (set-attribute-properties occurence-name att (cdr attribute-spec)) + (setf (find-attribute occurence-name attribute-name) + (cons (car attribute-spec) + (plist-nunion + (cdr attribute-spec) + (when att (description.properties att)))))))) (defmethod perform-define-attributes ((occurence-name t) attributes) (loop for attribute in attributes do (destructuring-bind (name type &rest args) attribute - (cond ((eq type t) - ;;use the existing (default) type - (set-attribute-properties occurence-name name args)) - ((not (null type)) - ;;set the type as well - (set-attribute occurence-name name (cons type args))))))) + (cond ((not (null type)) + ;;set the type as well + (set-attribute occurence-name name (cons type args))))))) (defmacro define-attributes (occurence-names &body attribute-definitions) `(progn ,@(loop for occurence-name in occurence-names collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions))))) +(defmethod find-display-attribute (occurence name) + (find-attribute occurence (intern (symbol-name name) "KEYWORD"))) + +(defmethod find-description (object type) + (let ((occurence (find-occurence object))) + (or (find-display-attribute + occurence + type) + occurence))) (defmethod setter (attribute) (warn "Setting ~A in ~A" attribute *context*) - (let ((setter (getf (attribute.properties attribute) :setter)) - (slot-name (getf (attribute.properties attribute) :slot-name))) + (let ((setter (getf (description.properties attribute) :setter)) + (slot-name (getf (description.properties attribute) :slot-name))) (cond (setter setter) (slot-name @@ -196,29 +244,38 @@ using the attributes defined in an occurence. Presentation Attributes are always (setf (slot-value object slot-name) value))) (t #'(lambda (value object) - (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute)))))) + (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute)))))) -(defmethod getter (attribute) - (let ((getter (getf (attribute.properties attribute) :getter)) - (slot-name (getf (attribute.properties attribute) :slot-name))) - (cond (getter - getter) - (slot-name - #'(lambda (object) - (when (slot-boundp object slot-name) - (slot-value object slot-name))))))) - (define-layered-function attribute-value (instance attribute) (:documentation " Like SLOT-VALUE for instances, the base method calls GETTER.")) (define-layered-method attribute-value (instance (attribute standard-attribute)) - (funcall (getter attribute) instance)) - -(define-layered-function (setf attribute-value) (value instance attribute)) + (with-slots (getter slot-name) attribute + (cond ((and (slot-boundp attribute 'getter) getter) + (funcall getter instance)) + ((and (slot-boundp attribute 'slot-name) slot-name) + (when (slot-boundp instance slot-name) + (slot-value instance slot-name))) + ((and (slot-exists-p instance (attribute.name attribute)) ) + (when (slot-boundp instance (attribute.name attribute)) + (slot-value instance (attribute.name attribute))))))) + +(define-layered-function (setf attribute-value) (value instance attribute)) + +(define-layered-method + (setf attribute-value) (value instance (attribute standard-attribute)) + (with-slots (setter slot-name) attribute + (cond ((and (slot-boundp attribute 'setter) setter) + + (funcall setter value instance)) + ((and (slot-boundp attribute 'slot-name) slot-name) + (setf (slot-value instance slot-name) value)) + ((and (slot-exists-p instance (attribute.name attribute)) slot-name) + (setf (slot-value instance (attribute.name attribute)) value)) + (t + (error "Cannot set ~A in ~A" attribute instance))))) -(define-layered-method (setf attribute-value) (value instance (attribute standard-attribute)) - (funcall (setter attribute) value instance)) ;;;; ** Default Attributes @@ -251,13 +308,13 @@ using the attributes defined in an occurence. Presentation Attributes are always (defun find-presentation-attributes (occurence-name) (loop for att in (find-all-attributes occurence-name) - when (typep att 'presentation-attribute) + when (typep att 'display-attribute) collect att)) (defun attribute-to-definition (attribute) (nconc (list (attribute.name attribute) - (attribute.type attribute)) - (attribute.properties attribute))) + (description.type attribute)) + (description.properties attribute))) (defun find-default-presentation-attribute-definitions () (if (eql *default-attributes-class-name* 'default) @@ -273,9 +330,9 @@ using the attributes defined in an occurence. Presentation Attributes are always (real-default (find-attribute 'default type))) (cond (possible-default - (attribute.type possible-default)) + (description.type possible-default)) (real-default - (attribute.type real-default)) + (description.type real-default)) (t type)))) (defun gen-presentation-slots (instance) @@ -292,7 +349,10 @@ using the attributes defined in an occurence. Presentation Attributes are always -;;;presentations +;;;; DEPRECIATED: Mewa presentations +;;;; this is legacy cruft. + + (defcomponent mewa () ((instance :accessor instance :initarg :instance) (attributes @@ -344,21 +404,22 @@ using the attributes defined in an occurence. Presentation Attributes are always (declare (type list plist) (type symbol att-name)) "This is a ucw specific function that will eventually be factored elsewhere." (let* ((attribute (find-attribute occurence att-name)) - (type (when attribute (or type (attribute.type attribute)))) + (type (when attribute (or type (description.type attribute)))) (class-name (or (gethash (if (consp type) (car type) type) *presentation-slot-type-mapping*) (error "Can't find slot type for ~A in ~A from ~A" att-name occurence parent-presentation)))) - - (cons (attribute.name attribute) (apply #'make-instance + + ;(warn "~%~% **** Making attribute ~A ~%~%" class-name) + (cons (attribute.name attribute) (apply #'make-instance class-name (append (plist-nunion plist (plist-union (global-properties parent-presentation) - (attribute.properties attribute))) + (description.properties attribute))) (list :size 30 :parent parent-presentation)))))) (defmethod find-applicable-attributes-using-attribute-list (occurence attribute-list) @@ -432,15 +493,16 @@ in that object presentation." (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil)) + (warn "making old-style for ~A ~A ~A" object type initargs) ;(warn "Initargs : ~A" initargs) - (let* ((a (find-attribute object type)) + (let* ((a (find-attribute object type)) + (d-a (when a (find-display-attribute (occurence a) (description.type (occurence a))))) (i (apply #'make-instance - (if a - (attribute.type a) + (if d-a + (find-old-type (description.type a)) type) (plist-union initargs (when a - (attribute.properties a)))))) - + (description.properties a)))))) (setf (slot-value i 'instance) object) (initialize-slots i) (setf (slot-value i 'initializedp) t)