X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/1718b9ff5ab93ffc63ae132f77ab67d2ceb10693..598f1fa8d4a53d8b531ee283b69bba52f3a4bd13:/src/mewa.lisp?ds=inline diff --git a/src/mewa.lisp b/src/mewa.lisp index a0300f6..be27094 100644 --- a/src/mewa.lisp +++ b/src/mewa.lisp @@ -1,22 +1,11 @@ - - -(in-package :mewa) +(in-package :lisp-on-lines) (defparameter *default-type* :ucw) -;;; maps meta-model slot-types to slot-presentation -(defparameter *slot-type-map* '(number ucw:currency)) - -;;; an alist of model-class-name . attributes -;;; should really be a hash-table. -(defvar *attribute-map* (list)) - ;;; some utilities for merging plists (defun plist-nunion (new-props plist) - (loop for cons on new-props - for i from 1 - when (oddp i) + (loop for cons on new-props by #'cddr do (setf (getf plist (first cons)) (second cons)) finally (return plist))) @@ -24,31 +13,16 @@ "Non-destructive version of plist-nunion" (plist-nunion new-props (copy-list plist))) -(defun gen-ptype (type) - (or (getf *slot-type-map* type) type)) - -(defun gen-presentation-slots (instance) - (mapcar #'(lambda (x) (gen-pslot (cadr x) - (string (car x)) - (car x))) - (list-slot-types instance))) - - -(defun gen-pslot (type label slot-name) - (copy-list `(,(gen-ptype type) - :label ,label - :slot-name ,slot-name))) - -(defun gen-presentation-args (instance args) - (declare (ignore instance)) - (if args args nil)) +;;; 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 nreeame." +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*)) @@ -62,6 +36,9 @@ attributes is an alist keyed on the attribute nreeame." (defmethod find-class-attributes ((model symbol)) (find-or-create-attributes model)) +(defmethod clear-class-attributes ((model t)) + (setf (cdr (find-class-attributes model)) nil)) + (defmethod add-attribute ((model t) name def) (let ((map (find-class-attributes model))) (setf (cdr map) (acons name def (cdr map))))) @@ -85,13 +62,141 @@ attributes is an alist keyed on the attribute nreeame." (cons (car definition) (plist-union (cdr definition) (cddr (find-attribute model name)))) - definition))) + 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) ))) + +(defmethod perform-set-attribute-properties ((model t) definitions) + (dolist (def definitions) + (funcall #'set-attribute-properties model (car def) (cdr def)))) + +(defmethod perform-define-attributes ((model 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))))))) + +(defmacro define-attributes (models &body attribute-definitions) + `(progn + ,@(loop for model in models + collect `(perform-define-attributes (quote ,model) (quote ,attribute-definitions))) + (mapcar #'find-class-attributes (quote ,models )))) + +(defun find-presentation-attributes (model) + (remove nil (mapcar #'(lambda (att) + (when (keywordp (car att)) + (copy-list att) )) + (cdr (find-class-attributes model))))) + + +;;;; ** Default Attributes + + +;;;; The default mewa class contains the types use as defaults. +;;;; maps meta-model slot-types to slot-presentation + +(defvar *default-attributes-class-name* 'default) + +(define-attributes (default) + (boolean mewa-boolean) + (string mewa-string) + (number mewa-currency) + (integer mewa-integer) + (currency mewa-currency) + (clsql:generalized-boolean mewa-boolean) + (foreign-key foreign-key) + (: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*))))) + + +(defmacro with-default-attributes ((model-name) &body body) + `(let ((*default-attributes-class-name* ',model-name)) + ,@body)) + +(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))) + +(defun gen-presentation-slots (instance) + (mapcar #'(lambda (x) (gen-pslot (cadr x) + (string (car x)) + (car x))) + (meta-model:list-slot-types instance))) + + +(defun gen-pslot (type label slot-name) + (copy-list `(,(gen-ptype type) + :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 + (defcomponent mewa () - ((attributes + ((instance :accessor instance :initarg :instance) + (attributes :initarg :attributes :accessor attributes :initform nil) @@ -99,6 +204,9 @@ attributes is an alist keyed on the attribute nreeame." :accessor attributes-getter :initform #'get-attributes :initarg :attributes-getter) + (attribute-slot-map + :accessor attribute-slot-map + :initform nil) (global-properties :initarg :global-properties :accessor global-properties @@ -112,29 +220,22 @@ attributes is an alist keyed on the attribute nreeame." :accessor use-instance-class-p :initform t) (initializedp :initform nil) - (modifiedp :accessor modifiedp :initform nil))) - -(defcomponent mewa-object-presentation (mewa object-presentation) ()) + (modifiedp :accessor modifiedp :initform nil :initarg :modifiedp) + (modifications :accessor modifications :initform nil))) -(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 (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self))))) @@ -177,85 +278,164 @@ attributes is an alist keyed on the attribute nreeame." (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))))) - - ) - ) + (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)))))) + (defmethod find-slot-presentations ((self mewa)) - (mapcar #'(lambda (s) - (let ((class-name (or (gethash (second s) ucw::*slot-type-mapping*) 'mewa-object-presentation))) - (apply #'make-instance - class-name - (append (cddr s) (list :parent self))))) + (mapcar #'(lambda (a) (find-slot-presentation-for-attribute self a)) (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 find-attribute-slot ((self mewa) (attribute symbol)) + (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 (slots self) (find-slot-presentations self))) - - -(defmethod render-on :around ((res response) (self mewa)) - (unless (slot-value self 'initializedp) - (initialize-slots self)) - (setf (slot-value self 'initializedp) t) - (call-next-method)) + (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)) + ;(warn "Initargs : ~A" initargs) (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))))) + (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) + (initialize-slots i) + (setf (slot-value i 'initializedp) t) i)) -(defmethod call-component :before ((from standard-component) (to mewa)) +(defmethod make-presentation ((list list) &key (type :listing) (initargs nil)) + (let ((args (append + `(:type ,type) + `(:initargs + (:instances ,list + ,@initargs))))) + + (apply #'make-presentation (car list) args))) + +(defmethod initialize-slots-place ((place ucw::place) (mewa mewa)) + (setf (slots mewa) (mapcar #'(lambda (x) + (prog1 x + (setf (component.place x) place))) + (slots 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))) \ No newline at end of file + `(present-object ,object :presentation (make-presentation ,object ,@args))) + + +(defcomponent about-dialog (option-dialog) + ((body :initarg :body))) + +(defmethod render-on ((res response) (self about-dialog)) + (call-next-method) + (render-on res (slot-value self 'body))) + + + + +(defaction cancel-save-instance ((self mewa)) + (cond + ((meta-model::persistentp (instance self)) + (meta-model::update-instance-from-records (instance self)) + (answer self)) + (t (answer nil)))) + +(defaction save-instance ((self mewa)) + (meta-model:sync-instance (instance self)) + (setf (modifiedp self) nil) + (answer self)) + +(defmethod confirm-sync-instance ((self mewa)) + nil) + +(defaction ensure-instance-sync ((self mewa)) + (when (modifiedp self) + (if nil + (let ((message (format nil "Record has been modified, Do you wish to save the changes?"))) + (case (call 'about-dialog + :body (make-presentation (instance self) + :type :viewer) + :message message + :options '((:save . "Save changes to Database") + (:cancel . "Cancel all changes"))) + (:cancel + (cancel-save-instance self)) + (:save + (save-instance self)))) + (save-instance self)))) + +(defaction sync-and-answer ((self mewa)) + (ensure-instance-sync self) + (answer (instance self))) + +(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)) + (sync-and-answer self)) + +(defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance) + (let* ((old (prog1 + (presentation-slot-value slot instance) + (call-next-method))) + (new (presentation-slot-value slot instance))) + + (unless (equal new old ) + (let ((self (ucw::parent slot))) + (setf (modifiedp self) instance + (modifications self) (append (list new old value slot instance) (modifications self))))))) + + + + + + + +;; This software is Copyright (c) Drew Crampsie, 2004-2005. +;; You are granted the rights to distribute +;; and use this software as governed by the terms +;; of the Lisp Lesser GNU Public License +;; (http://opensource.franz.com/preamble.html), +;; known as the LLGPL.