From 19531fbd947da15a17f8e5557a1a1492eab2bca3 Mon Sep 17 00:00:00 2001 From: drewc Date: Tue, 7 Jun 2005 19:49:22 -0700 Subject: [PATCH] re-organized a little, and added support for calling make-presentation with a class-name as well as a keyword attribute darcs-hash:20050608024922-39164-80eddff7bb5836f30fe8cfcd894f050ce32e8c9b.gz --- lisp-on-lines.asd | 5 +- src/{ => mewa}/mewa.lisp | 79 ++++++++++--------- .../slot-presentations.lisp} | 8 +- 3 files changed, 51 insertions(+), 41 deletions(-) rename src/{ => mewa}/mewa.lisp (91%) rename src/{ucw.lisp => mewa/slot-presentations.lisp} (96%) diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd index 031faa3..89ac0d1 100644 --- a/lisp-on-lines.asd +++ b/lisp-on-lines.asd @@ -26,10 +26,11 @@ (defsystem :mewa :components ((:module :src - :pathname "src/" + :pathname "src/mewa/" :components ((:file "mewa") - (:file "ucw" :depends-on ("mewa"))))) + (:file "presentations" :depends-on ("mewa")) + (:file "slot-presentations" :depends-on ("presentations"))))) :depends-on (:ucw :meta-model)) (defsystem :lisp-on-lines diff --git a/src/mewa.lisp b/src/mewa/mewa.lisp similarity index 91% rename from src/mewa.lisp rename to src/mewa/mewa.lisp index a0300f6..8509f2d 100644 --- a/src/mewa.lisp +++ b/src/mewa/mewa.lisp @@ -1,5 +1,3 @@ - - (in-package :mewa) (defparameter *default-type* :ucw) @@ -88,8 +86,28 @@ attributes is an alist keyed on the attribute nreeame." definition))) +(defmethod default-attributes ((model t)) + (append (mapcar #'(lambda (s) (cons (car s) (gen-pslot (if (meta-model:foreign-key-p model (car s)) + 'ucw::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) `(:presentation (make-presentation ,model :type :one-line))))) + (meta-model:list-has-many model)))) + +(defmethod set-default-attributes ((model t)) + (mapcar #'(lambda (x) + (setf (find-attribute model (car x)) (cdr x))) + (default-attributes model))) + + (defgeneric attributes-getter (model)) +;;;presentations + + + + (defcomponent mewa () ((attributes :initarg :attributes @@ -114,26 +132,19 @@ attributes is an alist keyed on the attribute nreeame." (initializedp :initform nil) (modifiedp :accessor modifiedp :initform nil))) -(defcomponent mewa-object-presentation (mewa object-presentation) ()) - -(defcomponent mewa-one-line-presentation (mewa one-line-presentation) - () - (:default-initargs :attributes-getter #'one-line-attributes-getter)) (defmethod attributes :around ((self mewa)) (let ((a (call-next-method))) (or a (funcall (attributes-getter self) self)))) +(defgeneric get-attributes (mewa)) + (defmethod get-attributes ((self mewa)) (if (instance self) (append (meta-model:list-slots (instance self)) (meta-model:list-has-many (instance self))) nil)) -(defmethod one-line-attributes-getter ((self mewa)) - (or (meta-model:list-keys (instance self)))) - - (defmethod find-instance-classes ((self mewa)) (mapcar #'class-name @@ -196,31 +207,6 @@ attributes is an alist keyed on the attribute nreeame." (append (cddr s) (list :parent self))))) (find-applicable-attributes self))) -(defmethod default-attributes ((model t)) - (append (mapcar #'(lambda (s) (cons (car s) (gen-pslot (if (meta-model:foreign-key-p model (car s)) - 'ucw::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) `(:presentation (make-presentation ,model :type :one-line))))) - (meta-model:list-has-many model)))) - -(defmethod set-default-attributes ((model t)) - (mapcar #'(lambda (x) - (setf (find-attribute model (car x)) (cdr x))) - (default-attributes model))) - - -(defcomponent mewa-object-presentation (mewa ucw:object-presentation) ()) - -(defcomponent mewa-list-presentation (mewa ucw:list-presentation) - ((it.bese.ucw::instances :accessor instances :initarg :instances :initform nil) - (instance :accessor instance))) ;to make make-presentation happy - -(defmethod get-all-instances ((self mewa-list-presentation)) - (instances self)) - - (defmethod initialize-slots ((self mewa)) @@ -248,6 +234,27 @@ attributes is an alist keyed on the attribute nreeame." (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) + (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))))) + (setf (slot-value i 'instance) object) + i)) + + + + + (defmethod call-component :before ((from standard-component) (to mewa)) (unless (slot-value to 'initializedp) (initialize-slots to)) diff --git a/src/ucw.lisp b/src/mewa/slot-presentations.lisp similarity index 96% rename from src/ucw.lisp rename to src/mewa/slot-presentations.lisp index ddf83af..4d89895 100644 --- a/src/ucw.lisp +++ b/src/mewa/slot-presentations.lisp @@ -13,6 +13,9 @@ (defmethod (setf presentation-slot-value) ((value string) (slot clsql-wall-time-slot-presentation) instance) (setf (presentation-slot-value slot instance) (clsql:parse-date-time (remove #\Space value)))) +(defmethod label :around ((slot clsql-wall-time-slot-presentation)) + (concatenate 'string (call-next-method) " (mm/dd/yyyy)")) + (defmethod present-slot ((slot clsql-wall-time-slot-presentation) instance) (let ((date (presentation-slot-value slot instance)) (input-id (string (gensym)))) @@ -35,14 +38,13 @@ (defmethod present-relation ((slot mewa-relation-slot-presentation) instance) ;;;;(<:as-html (slot-name slot) "=> " (foreign-instance slot) " from " instance ) - (let* ((e (getf (mewa::global-properties (parent slot)) :editablep)) - (i (foreign-instance slot)) + (let* ((i (foreign-instance slot)) (pres (mewa::make-presentation i :type :one-line :initargs (list :global-properties - (list :editablep nil :linkedp (linkedp slot)))))) + (list :editablep nil :linkedp nil))))) (when (ucw::parent slot) (setf (component.place pres) (component.place (ucw::parent slot)))) (flet ((render () (when i (