X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/15bc66bdec222f512812a9db7e0789bb45b20fb3..d0301620ac9aa7d8170ba628df493c1ff1e1d2fa:/src/mewa.lisp diff --git a/src/mewa.lisp b/src/mewa.lisp index fcfead4..c8fe7a5 100644 --- a/src/mewa.lisp +++ b/src/mewa.lisp @@ -1,5 +1,7 @@ +(declaim (optimize (speed 2) (space 3) (safety 0))) + (in-package :lisp-on-lines) - + (defparameter *default-type* :ucw) ;;;; I think these are unused now @@ -20,7 +22,8 @@ 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))) + finally (return plist)) + plist) (defun plist-union (new-props plist) "Non-destructive version of plist-nunion" @@ -55,9 +58,11 @@ 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))))) @@ -67,9 +72,22 @@ Attributes are the metadata used to display, validate, and otherwise manipulate 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)) + (properties :layered-accessor attribute.properties :initarg :properties :initform nil)) (: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)))) + `(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))) + (defmethod find-attribute-class-for-type ((type (eql ',type))) + ',name)))) (defmethod print-object ((self standard-attribute) stream) (print-unreadable-object (self stream :type t) @@ -86,17 +104,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 'standard-attribute)) -(defmethod ensure-attribute ((occurence standard-occurence) name type plist) +(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)) + +(defmethod ensure-attribute ((occurence standard-occurence) name type properties) "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))) + (make-attribute :name name :type type :properties properties))) (defmethod find-attribute ((occurence standard-occurence) name) (gethash name (attribute-map occurence))) @@ -105,12 +133,12 @@ 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) +(defmethod ensure-attribute (occurence-name name type properties) (ensure-attribute (find-occurence occurence-name) name type - plist)) + properties)) ;;;; The following functions make up the public interface to the ;;;; MEWA Attribute Occurence system. @@ -131,13 +159,13 @@ using the attributes defined in an occurence. Presentation Attributes are always (if (and att inherit) (cons (car definition) (plist-union (cdr definition) - (attribute.plist att))) + (attribute.properties att))) definition)))) (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))) + (setf (attribute.properties a) (plist-nunion properties (attribute.properties a))) (error "Attribute ~A does not exist" attribute)))) (defmethod perform-define-attributes ((occurence-name t) attributes) @@ -158,8 +186,9 @@ using the attributes defined in an occurence. Presentation Attributes are always (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 (attribute.properties attribute) :setter)) + (slot-name (getf (attribute.properties attribute) :slot-name))) (cond (setter setter) (slot-name @@ -170,8 +199,8 @@ using the attributes defined in an occurence. Presentation Attributes are always (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))) + (let ((getter (getf (attribute.properties attribute) :getter)) + (slot-name (getf (attribute.properties attribute) :slot-name))) (cond (getter getter) (slot-name @@ -179,13 +208,17 @@ using the attributes defined in an occurence. Presentation Attributes are always (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))) -(defgeneric (setf attribute-value) (value instance attribute) - (:method (value instance (attribute standard-attribute)) - (funcall (setter attribute) value 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)) + (funcall (getter attribute) instance)) + +(define-layered-function (setf attribute-value) (value instance attribute)) + +(define-layered-method (setf attribute-value) (value instance (attribute standard-attribute)) + (funcall (setter attribute) value instance)) ;;;; ** Default Attributes @@ -224,7 +257,7 @@ using the attributes defined in an occurence. Presentation Attributes are always (defun attribute-to-definition (attribute) (nconc (list (attribute.name attribute) (attribute.type attribute)) - (attribute.plist attribute))) + (attribute.properties attribute))) (defun find-default-presentation-attribute-definitions () (if (eql *default-attributes-class-name* 'default) @@ -257,31 +290,7 @@ 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 (defcomponent mewa () @@ -330,10 +339,6 @@ 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)) @@ -353,7 +358,7 @@ using the attributes defined in an occurence. Presentation Attributes are always plist (plist-union (global-properties parent-presentation) - (attribute.plist attribute))) + (attribute.properties attribute))) (list :size 30 :parent parent-presentation)))))) (defmethod find-applicable-attributes-using-attribute-list (occurence attribute-list) @@ -434,7 +439,7 @@ in that object presentation." (attribute.type a) type) (plist-union initargs (when a - (attribute.plist a)))))) + (attribute.properties a)))))) (setf (slot-value i 'instance) object) (initialize-slots i) @@ -477,8 +482,6 @@ in that object presentation." (render-on res (slot-value self 'body))) - - (defaction cancel-save-instance ((self mewa)) (cond ((meta-model::persistentp (instance self))