src/mewa/mewa.lisp

   1 (in-package :mewa)
   2
   3 (defparameter *default-type* :ucw)
   4
   5 ;;; maps meta-model slot-types to slot-presentation
   6 (defparameter *slot-type-map* '(number ucw:currency))
   7
   8 ;;; an alist of model-class-name . attributes
   9 ;;; should really be a hash-table.
  10 (defvar *attribute-map* (list))
  11
  12 ;;; some utilities for merging plists
  13
  14 (defun plist-nunion (new-props plist)
  15   (loop for cons on new-props by #'cddr
  16         do (setf (getf plist (first cons)) (second cons))
  17         finally (return plist)))
  18
  19 (defun plist-union (new-props plist)
  20   "Non-destructive version of plist-nunion"
  21                    (plist-nunion new-props (copy-list plist)))
  22
  23 (defun gen-ptype (type)
  24   (or (getf *slot-type-map* type) type))
  25
  26 (defun gen-presentation-slots (instance)
  27   (mapcar #'(lambda (x) (gen-pslot (cadr x)
  28                                    (string (car x))
  29                                    (car x)))
  30           (list-slot-types instance)))
  31
  32
  33 (defun gen-pslot (type label slot-name)
  34   (copy-list `(,(gen-ptype type)
  35                :label ,label
  36                :slot-name ,slot-name)))
  37
  38 (defun gen-presentation-args (instance args)
  39   (declare (ignore instance))
  40   (if args args nil))
  41
  42
  43 (defun find-or-create-attributes (class-name)
  44   "return an exisiting class attribute map or create one.
  45
  46 A map is a cons of class-name . attributes.
  47 attributes is an alist keyed on the attribute nreeame."
  48   (or (assoc class-name *attribute-map*)
  49       (progn
  50         (setf *attribute-map* (acons class-name (list (list)) *attribute-map*))
  51         (assoc class-name *attribute-map*))))
  52
  53 (defgeneric find-class-attributes (class))
  54
  55 (defmethod find-class-attributes ((model t))
  56   (find-or-create-attributes (class-name (class-of model))))
  57
  58 (defmethod find-class-attributes ((model symbol))
  59   (find-or-create-attributes model))
  60
  61 (defmethod add-attribute ((model t) name def)
  62   (let ((map (find-class-attributes model)))
  63     (setf (cdr map) (acons name def (cdr map)))))
  64
  65 (defmethod find-attribute ((model t) name)
  66   (assoc name (cdr (find-class-attributes model))))
  67
  68 (defmethod (setf find-attribute) ((def list) (model t) name)
  69   (let ((attr (find-attribute model name)))
  70     (if attr
  71         (prog2
  72             (setf (cdr attr) def)
  73             attr)
  74         (prog2
  75             (add-attribute model name def)
  76             (find-attribute model name)))))
  77
  78 (defmethod set-attribute ((model t) name definition &key (inherit t))
  79   (setf (find-attribute model name)
  80         (if inherit
  81             (cons (car definition)
  82                   (plist-union (cdr definition)
  83                          (cddr (find-attribute model name))))
  84             definition)))
  85
  86
  87 (defmethod default-attributes ((model t))
  88   "return the default attributes for a given model using the meta-model's meta-data"
  89   (append (mapcar #'(lambda (s)
  90                       (cons (car s)
  91                             (gen-pslot
  92                              (if (meta-model:foreign-key-p model (car s))
  93                                  'ucw::foreign-key
  94                                  (cadr s))
  95                              (string (car s)) (car s))))
  96                   (meta-model:list-slot-types model))
  97           (mapcar #'(lambda (s)
  98                       (cons s (append (gen-pslot 'ucw::has-many (string s) s)
  99                                       `(:presentation
 100                                         (make-presentation
 101                                          ,model
 102                                          :type :one-line)))))
 103                   (meta-model:list-has-many model))))
 104
 105 (defmethod set-default-attributes ((model t))
 106   (mapcar #'(lambda (x)
 107               (setf (find-attribute model (car x)) (cdr x)))
 108           (default-attributes model)))
 109
 110
 111 (defgeneric attributes-getter (model))
 112
 113 ;;;presentations
 114
 115
 116
 117
 118 (defcomponent mewa ()
 119   ((attributes
 120     :initarg :attributes
 121     :accessor attributes
 122     :initform nil)
 123    (attributes-getter
 124     :accessor attributes-getter
 125     :initform #'get-attributes
 126     :initarg :attributes-getter)
 127    (global-properties
 128     :initarg :global-properties
 129     :accessor global-properties
 130     :initform nil)
 131    (classes
 132     :initarg :classes
 133     :accessor classes
 134     :initform nil)
 135    (use-instance-class-p
 136     :initarg :use-instance-class-p
 137     :accessor use-instance-class-p
 138     :initform t)
 139    (initializedp :initform nil)
 140    (modifiedp :accessor modifiedp :initform nil)
 141    (modifications :accessor modifications :initform nil)))
 142
 143
 144 (defmethod attributes :around ((self mewa))
 145   (let ((a (call-next-method)))
 146     (or a (funcall (attributes-getter self) self))))
 147
 148 (defgeneric get-attributes (mewa))
 149
 150 (defmethod get-attributes ((self mewa))
 151   (if (instance self)
 152   (append (meta-model:list-slots (instance self))
 153           (meta-model:list-has-many (instance self)))
 154   nil))
 155
 156
 157 (defmethod find-instance-classes ((self mewa))
 158   (mapcar #'class-name
 159           (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
 160
 161 (defmethod find-all-attributes ((self mewa))
 162   (reduce #'append
 163           (mapcar #'(lambda (x)
 164                       (cdr (find-class-attributes x)))
 165                   (classes self))))
 166
 167 (defun make-attribute (&rest props &key type &allow-other-keys)
 168         (remf props :type)
 169         (cons (gensym) (cons type props)))
 170
 171
 172 (defmethod find-applicable-attributes ((self mewa))
 173   (let ((all-attributes (find-all-attributes self)))
 174     (flet ((gen-att (x) (let ((att (assoc x all-attributes)))
 175                                      (when att
 176                                        (setf (cddr att) (plist-union (global-properties self) (cddr att)))
 177                                        att))))
 178     (if (attributes self)
 179         (remove 'nil
 180                 (mapcar #'(lambda (x)
 181                             (cond
 182                              ;;simple casee
 183                              ((symbolp x)
 184                               (gen-att x))
 185                              ;;if the car is a keyword then this is an inline def
 186                              ((and (listp x) (keywordp (car x)))
 187                               (let ((att (apply #'make-attribute x)))
 188                                 (setf (cddr att)
 189                                       (plist-union (cddr att) (global-properties self)))
 190                                 att))
 191                              ;; if the plist has a :type
 192                              ((and (listp x) (getf (cdr x) :type))
 193                               (let ((new (cdr (apply #'make-attribute (cdr x))))
 194                                     (def (gen-att (car x))))
 195                                 (setf (cdr new) (plist-union (cdr new) (cddr def)))
 196                                 (cons (car def) new)))
 197                              ;;finally if we are just overiding the props
 198                              ((and (listp x) (symbolp (car x)))
 199                               (let ((new (cdr (apply #'make-attribute (cdr x))))
 200                                     (def (gen-att (car x))))
 201                                 (setf (cdr new) (plist-union (cdr new) (cddr def)))
 202                                 (cons (car def) (cons (second def) (cdr new)))))
 203
 204                               )
 205                              )
 206
 207                         (attributes self)))
 208       all-attributes))))
 209
 210 (defmethod find-slot-presentations ((self mewa))
 211   (mapcar #'(lambda (s)
 212               (let ((class-name (or (gethash (second s) ucw::*slot-type-mapping*) 'mewa-object-presentation)))
 213               (apply #'make-instance
 214                      class-name
 215                      (append (cddr s) (list :parent self)))))
 216           (find-applicable-attributes self)))
 217
 218
 219
 220 (defmethod initialize-slots ((self mewa))
 221   (when (use-instance-class-p self)
 222     (setf (classes self)
 223           (append (find-instance-classes self)
 224                   (classes self))))
 225   (setf (slots self) (find-slot-presentations   self)))
 226
 227
 228 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
 229   (let* ((p (make-instance 'mewa-object-presentation))
 230          (a (progn (setf (slot-value p 'instance) object)
 231                    (initialize-slots p)
 232                    (assoc type (find-all-attributes p))))
 233
 234          (i (apply #'make-instance (second a) (plist-union initargs (cddr a)))))
 235     (setf (slot-value i 'instance) object)
 236     i))
 237
 238 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
 239   (let* ((p (make-instance 'mewa-object-presentation))
 240          (a (progn (setf (slot-value p 'instance) object)
 241                    (initialize-slots p)
 242                    (assoc type (find-all-attributes p))))
 243
 244          (i (apply #'make-instance (or (second a)
 245                                        ;; if we didnt find the type,
 246                                        ;; use the symbol as a class.
 247                                        (if (eql (symbol-package type)
 248                                                 (find-package 'keyword))
 249                                            (symbol-name type)
 250                                            type))
 251                                        (plist-union initargs (cddr a)))))
 252     (setf (slot-value i 'instance) object)
 253     (initialize-slots i)
 254     (setf (slot-value i 'initializedp) t)
 255     i))
 256
 257
 258
 259
 260
 261 (defmethod call-component :before ((from standard-component) (to mewa))
 262   (unless (slot-value to 'initializedp)
 263     (initialize-slots to))
 264   (setf (slot-value to 'initializedp) t)
 265   (setf (slots to) (mapcar #'(lambda (x) (prog2
 266                                              (setf (component.place x) (component.place from))
 267                                              x))
 268                              (slots to))))
 269
 270 (defmacro call-presentation (object &rest args)
 271   `(present-object ,object :presentation (make-presentation ,object ,@args)))
 272
 273
 274
 275 (defaction cancel-save-instance ((self mewa))
 276   (cond
 277     ((slot-value (instance self) 'clsql-sys::view-database)
 278       (meta-model::update-instance-from-records (instance self))
 279       (answer self))
 280     (t (answer nil))))
 281
 282 (defaction save-instance ((self mewa))
 283   (meta-model:sync-instance (instance self))
 284    (setf (modifiedp self) nil)
 285        (answer self))
 286
 287
 288 (defaction ok ((self mewa) &optional arg)
 289   "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
 290   (declare (ignore arg))
 291   (when (modifiedp self)
 292     (let ((message (format nil "Record has been modified, Do you wish to save the changes?<br/> ~a" (print (modifications self)))))
 293       (case (call 'option-dialog
 294                   :message message
 295                   :options '((:save . "Save changes to Database")
 296                              (:cancel . "Cancel all changes")))
 297         (:cancel
 298          (cancel-save-instance self))
 299         (:save
 300          (save-instance self)))))
 301   (answer self))
 302
 303
 304
 305 (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
 306   (let* ((old (prog1
 307                  (presentation-slot-value slot instance)
 308                (call-next-method)))
 309         (new (presentation-slot-value slot instance)))
 310
 311   (unless (equal new old )
 312     (let ((self (ucw::parent slot)))
 313       (setf (modifiedp self) instance
 314             (modifications self)  (append (list  (type-of new) (type-of old) (type-of value) slot instance )))))))