X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/e0ae0cdefa99e9dc1b2e1938779558f1878c1864..a4e6154d961ff4b606aa534bd4e1570565cab351:/src/mewa.lisp diff --git a/src/mewa.lisp b/src/mewa.lisp index cf6ea00..7c712ef 100644 --- a/src/mewa.lisp +++ b/src/mewa.lisp @@ -1,105 +1,281 @@ -(in-package :mewa) - -(defparameter *default-type* :ucw) - -;;; some utilities for merging plists - -(defun plist-nunion (new-props plist) - (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))) - - -;;; an alist of model-class-name . attributes -;;; should really be a hash-table. -(defvar *attribute-map* (list)) - -(defun find-or-create-attributes (class-name) - "return an exisiting class attribute map or create one. - -A map is a cons of class-name . attributes. -attributes is an alist keyed on the attribute name." - (or (assoc class-name *attribute-map*) - (progn - (setf *attribute-map* (acons class-name (list (list)) *attribute-map*)) - (assoc class-name *attribute-map*)))) - -(defgeneric find-class-attributes (class)) - -(defmethod find-class-attributes ((model t)) - (find-or-create-attributes (class-name (class-of model)))) - -(defmethod find-class-attributes ((model symbol)) - (find-or-create-attributes model)) +(declaim (optimize (speed 2) (space 3) (safety 0))) -(defmethod clear-class-attributes ((model t)) - (setf (cdr (find-class-attributes model)) nil)) +(in-package :lisp-on-lines) -(defmethod add-attribute ((model t) name def) - (let ((map (find-class-attributes model))) - (setf (cdr map) (acons name def (cdr map))))) - -(defmethod find-attribute ((model t) name) - (assoc name (cdr (find-class-attributes model)))) - -(defmethod (setf find-attribute) ((def list) (model t) name) - (let ((attr (find-attribute model name))) - (if attr - (prog2 - (setf (cdr attr) def) - attr) - (prog2 - (add-attribute model name def) - (find-attribute model name))))) - -(defmethod set-attribute ((model t) name definition &key (inherit t)) - (setf (find-attribute model name) - (if inherit - (cons (car definition) - (plist-union (cdr definition) - (cddr (find-attribute model name)))) - definition))) - -(defmethod perform-set-attributes ((model t) definitions) - (dolist (def definitions) - (funcall #'set-attribute model (first def) (rest def)))) - -(defmethod set-attribute-properties ((model t) attribute properties) - (let ((a (find-attribute model attribute))) - (if a - (setf (cddr a) (plist-nunion properties (cddr a))) - (error "Attribute ~A does not exist" attribute) ))) +(defparameter *default-type* :ucw) -(defmethod perform-set-attribute-properties ((model t) definitions) - (dolist (def definitions) - (funcall #'set-attribute-properties model (car def) (cdr def)))) +(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) + "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 (description) + ((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.")) + +(defun find-or-create-occurence (name) + "Returns the occurence associated with this name." + (let ((occurence (gethash name *occurence-map*))) + (if occurence + occurence + (let ((new-occurence (make-instance 'standard-occurence))) + (setf (gethash name *occurence-map*) new-occurence) + new-occurence)))) + +(defun clear-occurence (occurence) + "removes all attributes from the occurence" + (setf (attribute-map occurence) (make-hash-table))) + +(defgeneric find-occurence (name) + (:method (thing) + nil) + (:method ((name symbol)) + (find-or-create-occurence name)) + (: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 (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)) + (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 + 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.")) + +(defun clear-attributes (name) + "removes all attributes from an occurance" + (clear-occurence (find-occurence name))) + +(defmethod find-attribute-class-for-type (type) + nil) -(defmethod perform-define-attributes ((model t) attributes) +(defmethod find-attribute-class-for-name (name) + "presentation attributes are named using keywords" + (if (keywordp name) + 'display-attribute + 'standard-attribute)) + +(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" + (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))) + +(defmethod find-all-attributes ((occurence standard-occurence)) + (loop for att being the hash-values of (attribute-map occurence) + collect att)) + +(defmethod ensure-attribute (occurence-name &rest args &key name type &allow-other-keys) + (declare (ignore name type)) + (apply #'ensure-attribute + (find-occurence occurence-name) + args)) + +;;;; The following functions make up the public interface to the +;;;; MEWA Attribute Occurence system. + +(defmethod find-all-attributes (occurence-name) + (find-all-attributes (find-occurence occurence-name))) + +(defmethod find-attribute (occurence-name attribute-name) + "Return the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name" + (find-attribute (find-occurence occurence-name) attribute-name)) + +(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 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) + (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 model name args)) - ((not (null type)) - ;;set the type as well - (set-attribute model name (cons type args))))))) + (cond ((not (null type)) + ;;set the type as well + (set-attribute occurence-name name (cons type args))))))) -(defmacro define-attributes (models &body attribute-definitions) +(defmacro define-attributes (occurence-names &body attribute-definitions) `(progn - ,@(loop for model in models - collect `(perform-define-attributes (quote ,model) (quote ,attribute-definitions))) - (mapcar #'find-class-attributes (quote ,models )))) + ,@(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 (description.properties attribute) :setter)) + (slot-name (getf (description.properties attribute) :slot-name))) + (cond (setter + setter) + (slot-name + #'(lambda (value object) + (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)))))) + + +(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))))) -(defun find-presentation-attributes (model) - (remove nil (mapcar #'(lambda (att) - (when (keywordp (car att)) - att)) - (cdr (find-class-attributes model))))) ;;;; ** Default Attributes @@ -110,6 +286,10 @@ attributes is an alist keyed on the attribute name." (defvar *default-attributes-class-name* 'default) +(defmacro with-default-attributes ((occurence-name) &body body) + `(let ((*default-attributes-class-name* ',occurence-name)) + ,@body)) + (define-attributes (default) (boolean mewa-boolean) (string mewa-string) @@ -121,29 +301,39 @@ attributes is an alist keyed on the attribute name." (:viewer mewa-viewer) (:editor mewa-editor) (:creator mewa-creator) + (:as-string mewa-one-line-presentation) (:one-line mewa-one-line-presentation) (:listing mewa-list-presentation :global-properties (:editablep nil) :editablep t) (:search-model mewa-object-presentation)) - -(defun find-default-presentation-attributes () - (if (eql *default-attributes-class-name* 'default) - (find-presentation-attributes 'default) - (remove-duplicates (append - (find-presentation-attributes 'default) - (find-presentation-attributes - *default-attributes-class-name*))))) +(defun find-presentation-attributes (occurence-name) + (loop for att in (find-all-attributes occurence-name) + when (typep att 'display-attribute) + collect att)) +(defun attribute-to-definition (attribute) + (nconc (list (attribute.name attribute) + (description.type attribute)) + (description.properties attribute))) -(defmacro with-default-attributes ((model-name) &body body) - `(let ((*default-attributes-class-name* ',model-name)) - ,@body)) - +(defun find-default-presentation-attribute-definitions () + (if (eql *default-attributes-class-name* 'default) + (mapcar #'attribute-to-definition (find-presentation-attributes 'default)) + (remove-duplicates (mapcar #'attribute-to-definition + (append + (find-presentation-attributes 'default) + (find-presentation-attributes + *default-attributes-class-name*)))))) (defun gen-ptype (type) - (let ((type (if (consp type) (car type) type))) - (or (second (find-attribute *default-attributes-class-name* type)) - (second (find-attribute 'default type)) - type))) + (let* ((type (if (consp type) (car type) type)) + (possible-default (find-attribute *default-attributes-class-name* type)) + (real-default (find-attribute 'default type))) + (cond + (possible-default + (description.type possible-default)) + (real-default + (description.type real-default)) + (t type)))) (defun gen-presentation-slots (instance) (mapcar #'(lambda (x) (gen-pslot (cadr x) @@ -157,41 +347,11 @@ attributes is an alist keyed on the attribute name." :label ,label :slot-name ,slot-name))) -(defun gen-presentation-args (instance args) - (declare (ignore instance)) - (if args args nil)) - - -(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-attributes))) - -(defmethod set-default-attributes ((model t)) - "Set the default attributes for MODEL" - (clear-class-attributes model) - (mapcar #'(lambda (x) - (setf (find-attribute model (car x)) (cdr x))) - (find-default-attributes model))) - - -(defgeneric attributes-getter (model)) + -;;;presentations +;;;; DEPRECIATED: Mewa presentations +;;;; this is legacy cruft. + (defcomponent mewa () ((instance :accessor instance :initarg :instance) @@ -239,69 +399,84 @@ attributes is an alist keyed on the attribute name." (mapcar #'class-name (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self))))) -(defmethod find-all-attributes ((self mewa)) - (reduce #'append - (mapcar #'(lambda (x) - (cdr (find-class-attributes x))) - (classes 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 (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)))) + + ;(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) + (description.properties attribute))) + (list :size 30 :parent parent-presentation)))))) + +(defmethod find-applicable-attributes-using-attribute-list (occurence attribute-list) + "Returns a list of functions that, when called with an object presentation, +returns the ucw slot presentation that will be used to present this attribute +in that object presentation." + (loop for att in attribute-list + with funs = (list) + do (let ((att att)) (cond + ;;simple casee + ((symbolp att) + (push #'(lambda (p) + (make-presentation-for-attribute-list-item occurence att nil p)) + funs)) + ;;if the car is a keyword then this is an inline def + ;; drewc nov 12 2005: + ;; i never used this, and never told anybody about it. + ;; removing it. + #+ (or) ((and (listp x) (keywordp (car x))) + (let ((att (apply #'make-attribute x))) + (setf (cddr att) + (plist-union (cddr att) (global-properties self))) + att)) + + ;; if the plist has a :type + ((and (listp att) (getf (cdr att) :type)) + (let ((type (getf (cdr att) :type))) + (push #'(lambda (p) + (make-presentation-for-attribute-list-item + occurence (first att) + (cdr att) + p + type)) + funs))) + ;;finally if we are just overiding the props + ((and (listp att) (symbolp (car att))) + (push #'(lambda (p) + (make-presentation-for-attribute-list-item occurence (first att) (rest att) p)) + funs)))) + finally (return (nreverse funs)))) + + +(defun find-attribute-names (mewa) + (mapcar #'(lambda (x) + (if (listp x) + (first x) + x)) + (attributes mewa))) (defmethod find-applicable-attributes ((self mewa)) - (let ((all-attributes (find-all-attributes self))) - (flet ((gen-att (x) (let ((att (assoc x all-attributes))) - (when att - (setf (cddr att) (plist-union (global-properties self) (cddr att))) - att)))) - (if (attributes self) - (remove 'nil - (mapcar #'(lambda (x) - (cond - ;;simple casee - ((symbolp x) - (gen-att x)) - ;;if the car is a keyword then this is an inline def - ((and (listp x) (keywordp (car x))) - (let ((att (apply #'make-attribute x))) - (setf (cddr att) - (plist-union (cddr att) (global-properties self))) - att)) - ;; if the plist has a :type - ((and (listp x) (getf (cdr x) :type)) - (let ((new (cdr (apply #'make-attribute (cdr x)))) - (def (gen-att (car x)))) - (setf (cdr new) (plist-union (cdr new) (cddr def))) - (cons (car def) new))) - ;;finally if we are just overiding the props - ((and (listp x) (symbolp (car x))) - (let ((new (cdr (apply #'make-attribute (cdr x)))) - (def (gen-att (car x)))) - (setf (cdr new) (plist-union (cdr new) (cddr def))) - (cons (car def) (cons (second def) (cdr new))))) - - ) - ) - - (attributes self))) - all-attributes)))) - -(defmethod find-slot-presentation-for-attribute ((self mewa) attribute) - (let ((class-name - (or (gethash (if (consp (second attribute)) - (car (second attribute)) - (second attribute)) - *presentation-slot-type-mapping*) - (error "Can't find slot type for ~A in ~A" attribute self )))) - - (cons (first attribute) (apply #'make-instance - class-name - (append (cddr attribute) (list :parent self :size 30)))))) + (if (attributes self) + (find-applicable-attributes-using-attribute-list (instance self) (attributes self)) + (find-applicable-attributes-using-attribute-list (instance (get-attributes self))))) + (defmethod find-slot-presentations ((self mewa)) - (mapcar #'(lambda (a) (find-slot-presentation-for-attribute self a)) + (mapcar #'(lambda (a) (funcall a self)) (find-applicable-attributes self))) (defmethod find-attribute-slot ((self mewa) (attribute symbol)) @@ -318,25 +493,22 @@ attributes is an alist keyed on the attribute name." (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil)) - (let* ((p (make-instance 'mewa-object-presentation)) - (a (progn (setf (slot-value p 'instance) object) - (initialize-slots p) - (assoc type (find-all-attributes p)))) - (i (apply #'make-instance (or (second a) - ;; if we didnt find the type, - ;; use the symbol as a class. - (if (eql (symbol-package type) - (find-package 'keyword)) - (symbol-name type) - type)) - (plist-union initargs (cddr a))))) + (warn "making old-style for ~A ~A ~A" object type initargs) + ;(warn "Initargs : ~A" initargs) + (let* ((a (find-attribute object type)) + (d-a (when a (find-display-attribute (occurence a) (description.type (occurence a))))) + (i (apply #'make-instance + (if d-a + (find-old-type (description.type a)) + type) + (plist-union initargs (when a + (description.properties a)))))) (setf (slot-value i 'instance) object) (initialize-slots i) (setf (slot-value i 'initializedp) t) i)) -(defmethod make-presentation ((list list) &key (type :listing) (initargs nil)) - +(defmethod make-presentation ((list list) &key (type :listing) (initargs nil)) (let ((args (append `(:type ,type) `(:initargs @@ -371,15 +543,10 @@ attributes is an alist keyed on the attribute name." (call-next-method) (render-on res (slot-value self 'body))) -(defmethod instance-is-stored-p ((instance clsql:standard-db-object)) - (slot-value instance 'clsql-sys::view-database)) - -(defmethod instance-is-stored-p ((mewa mewa)) - (instance-is-stored-p (instance mewa))) (defaction cancel-save-instance ((self mewa)) (cond - ((instance-is-stored-p (instance self)) + ((meta-model::persistentp (instance self)) (meta-model::update-instance-from-records (instance self)) (answer self)) (t (answer nil))))