X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/569ad9e659b96d5bce12410bbc0a24710306cd3e..38a016c7ea89d37ea32cfeb8d1e30033c9e3d614:/src/mewa/mewa.lisp diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp index c6f14a3..af4ecbb 100644 --- a/src/mewa/mewa.lisp +++ b/src/mewa/mewa.lisp @@ -1,16 +1,14 @@ - (in-package :mewa) (defparameter *default-type* :ucw) ;;; maps meta-model slot-types to slot-presentation (defparameter *slot-type-map* - '(boolean ucw::mewa-boolean - string ucw::mewa-string - number ucw::mewa-currency - integer ucw::mewa-integer - currency ucw::mewa-currency - )) + '(boolean mewa-boolean + string mewa-string + number mewa-currency + integer mewa-integer + currency mewa-currency)) ;;; an alist of model-class-name . attributes ;;; should really be a hash-table. @@ -114,12 +112,12 @@ attributes is an alist keyed on the attribute name." (cons (car s) (gen-pslot (if (meta-model:foreign-key-p model (car s)) - 'ucw::foreign-key + 'foreign-key (cadr s)) (string (car s)) (car s)))) (meta-model:list-slot-types model)) (mapcar #'(lambda (s) - (cons s (append (gen-pslot 'ucw::has-many (string s) s) + (cons s (append (gen-pslot 'has-many (string s) s) `(:presentation (make-presentation ,model @@ -141,7 +139,8 @@ attributes is an alist keyed on the attribute name." (defcomponent mewa () - ((attributes + ((instance :accessor instance :initarg :instance) + (attributes :initarg :attributes :accessor attributes :initform nil) @@ -236,12 +235,15 @@ attributes is an alist keyed on the attribute name." (defmethod find-slot-presentation-for-attribute ((self mewa) attribute) (let ((class-name - (or (gethash (second attribute) ucw::*slot-type-mapping*) - (error "Can't find slot type for ~A" (second attribute))))) + (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 but ~A" attribute *presentation-slot-type-mapping* (gethash 'mewa:has-very-many *presentation-slot-type-mapping*))))) - (cons (first attribute) (apply #'make-instance - class-name - (append (cddr attribute) (list :parent self :size 30)))))) + (cons (first attribute) (apply #'make-instance + class-name + (append (cddr attribute) (list :parent self :size 30)))))) (defmethod find-slot-presentations ((self mewa)) (mapcar #'(lambda (a) (find-slot-presentation-for-attribute self a)) @@ -251,38 +253,27 @@ attributes is an alist keyed on the attribute name." (cdr (assoc attribute (attribute-slot-map self)))) (defmethod initialize-slots ((self mewa)) - (when (use-instance-class-p self) - (setf (classes self) - (append (find-instance-classes self) - (classes self)))) - (setf (attribute-slot-map self) (find-slot-presentations self)) - (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self )))) + (when (instance self) + (when (use-instance-class-p self) + (setf (classes self) + (append (find-instance-classes self) + (classes self)))) + (setf (attribute-slot-map self) (find-slot-presentations self)) + (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self ))))) - -(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 (second a) (plist-union initargs (cddr a))))) - (setf (slot-value i 'instance) object) - i)) - (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) + (a (progn (setf (slot-value p 'ucw::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))))) + ;; 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))))) (setf (slot-value i 'instance) object) (initialize-slots i) (setf (slot-value i 'initializedp) t) @@ -295,14 +286,14 @@ attributes is an alist keyed on the attribute name." (setf (component.place x) place))) (slots mewa)))) -(defmethod call-component :before ((from standard-component) (to mewa)) +(arnesi:defmethod/cc call-component :before ((from standard-component) (to mewa)) (unless (slot-value to 'initializedp) (initialize-slots to)) (setf (slot-value to 'initializedp) t) - (setf (slots to) (mapcar #'(lambda (x) (prog2 - (setf (component.place x) (component.place from)) - x)) - (slots to)))) + (initialize-slots-place (component.place from) to) + to) + + (defmacro call-presentation (object &rest args) `(present-object ,object :presentation (make-presentation ,object ,@args))) @@ -351,9 +342,9 @@ attributes is an alist keyed on the attribute name." (defaction ok ((self mewa) &optional arg) "Returns the component if it has not been modified. if it has been, prompt user to save or cancel" - (declare (ignore arg)) - (ensure-instance-sync self) - (answer self)) + ;(declare (ignore arg)) + (meta-model::sync-instance (instance self)) + (answer (instance self))) (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance) (let* ((old (prog1 @@ -372,11 +363,13 @@ attributes is an alist keyed on the attribute name." '(mewa-object-presentation :global-properties (:editablep nil)) (find-attribute t :editor) '(mewa-object-presentation :global-properties (:editablep t)) + (find-attribute t :creator) + '(mewa-object-presentation :global-properties (:editablep t)) (find-attribute t :one-line) - '(mewa::mewa-one-line-presentation) + '(mewa-one-line-presentation) (find-attribute t :listing) - '(mewa::mewa-list-presentation :global-properties (:editablep nil) :editablep t) - (find-attribute t :search-presentation) + '(mewa-list-presentation :global-properties (:editablep nil) :editablep t) + (find-attribute t :search-model) '(mewa-object-presentation))