X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/13ebe12f373ec67aa3d4a1c6ee35f8f5892719b7..e1645f63189477f1b39a173a41fcbbfefb5e88a6:/src/mewa.lisp diff --git a/src/mewa.lisp b/src/mewa.lisp index 203fdf3..7c712ef 100644 --- a/src/mewa.lisp +++ b/src/mewa.lisp @@ -4,40 +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))) - -(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. @@ -57,29 +58,65 @@ Attributes are the metadata used to display, validate, and otherwise manipulate (setf (attribute-map occurence) (make-hash-table))) (defgeneric find-occurence (name) + (:method (thing) + nil) (:method ((name symbol)) (find-or-create-occurence name)) - (:method (instance) + (:method ((instance standard-object)) (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) - (plist :layered-accessor attribute.plist :initarg :plist :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.")) - -(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)))) +(defmacro defattribute (name supers slots &rest args) + (let ((type (or (second (assoc :type-name args)) name)) + (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 + ;;;; 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)))) (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.")) @@ -88,17 +125,27 @@ using the attributes defined in an occurence. Presentation Attributes are always "removes all attributes from an occurance" (clear-occurence (find-occurence name))) +(defmethod find-attribute-class-for-type (type) + nil) + (defmethod find-attribute-class-for-name (name) "presentation attributes are named using keywords" (if (keywordp name) - 'presentation-attribute + 'display-attribute 'standard-attribute)) -(defmethod ensure-attribute ((occurence standard-occurence) name type plist) +(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) &rest args &key name &allow-other-keys) "Creates an attribute in the given occurence" - (setf (gethash name (attribute-map occurence)) - (make-instance (find-attribute-class-for-name name) - :name name :type type :plist plist))) + (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))) @@ -107,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 plist) - (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 - plist)) + args)) ;;;; The following functions make up the public interface to the ;;;; MEWA Attribute Occurence system. @@ -121,47 +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.plist 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.plist a) (plist-nunion properties (attribute.plist 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) - (let ((setter (getf (attribute.plist attribute) :setter)) - (slot-name (getf (attribute.plist attribute) :slot-name))) + (warn "Setting ~A in ~A" attribute *context*) + (let ((setter (getf (description.properties attribute) :setter)) + (slot-name (getf (description.properties attribute) :slot-name))) (cond (setter setter) (slot-name @@ -169,25 +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.plist attribute) :getter)) - (slot-name (getf (attribute.plist attribute) :slot-name))) - (cond (getter - getter) - (slot-name - #'(lambda (object) - (when (slot-boundp object slot-name) - (slot-value object slot-name))))))) -(defgeneric attribute-value (instance attribute) - (:method (instance (attribute standard-attribute)) - (funcall (getter attribute) instance))) +(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)) + (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))))) -(defgeneric (setf attribute-value) (value instance attribute) - (:method (value instance (attribute standard-attribute)) - (funcall (setter attribute) value instance))) ;;;; ** Default Attributes @@ -220,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.plist attribute))) + (description.type attribute)) + (description.properties attribute))) (defun find-default-presentation-attribute-definitions () (if (eql *default-attributes-class-name* 'default) @@ -242,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) @@ -259,33 +347,12 @@ using the attributes defined in an occurence. Presentation Attributes are always :label ,label :slot-name ,slot-name))) -(defmethod find-default-attributes ((model t)) - "return the default attributes for a given model using the meta-model's meta-data" - (append (mapcar #'(lambda (s) - (cons (car s) - (gen-pslot - (if (meta-model:foreign-key-p model (car s)) - 'foreign-key - (cadr s)) - (string (car s)) (car s)))) - (meta-model:list-slot-types model)) - (mapcar #'(lambda (s) - (cons s (append (gen-pslot 'has-many (string s) s) - `(:presentation - (make-presentation - ,model - :type :one-line))))) - (meta-model:list-has-many model)) - (find-default-presentation-attribute-definitions))) - -(defmethod set-default-attributes ((model t)) - "Set the default attributes for MODEL" - (clear-attributes model) - (mapcar #'(lambda (x) - (setf (find-attribute model (car x)) (cdr x))) - (find-default-attributes model))) + -;;;presentations +;;;; DEPRECIATED: Mewa presentations +;;;; this is legacy cruft. + + (defcomponent mewa () ((instance :accessor instance :initarg :instance) (attributes @@ -332,30 +399,27 @@ using the attributes defined in an occurence. Presentation Attributes are always (mapcar #'class-name (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self))))) -(defun make-attribute (&rest props &key type &allow-other-keys) - (remf props :type) - (cons (gensym) (cons type props))) - (defun make-presentation-for-attribute-list-item (occurence att-name plist parent-presentation &optional type) (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.plist attribute))) + (description.properties attribute))) (list :size 30 :parent parent-presentation)))))) (defmethod find-applicable-attributes-using-attribute-list (occurence attribute-list) @@ -429,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.plist a)))))) - + (description.properties a)))))) (setf (slot-value i 'instance) object) (initialize-slots i) (setf (slot-value i 'initializedp) t) @@ -479,8 +544,6 @@ in that object presentation." (render-on res (slot-value self 'body))) - - (defaction cancel-save-instance ((self mewa)) (cond ((meta-model::persistentp (instance self))