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   (append (mapcar #'(lambda (s) (cons (car s) (gen-pslot (if (meta-model:foreign-key-p model (car s))
  89                                                    (cadr s))
  90                                                  (string (car s)) (car s))))
  91           (meta-model:list-slot-types model))
  92           (mapcar #'(lambda (s) (cons s (append (gen-pslot 'ucw::has-many (string s) s) `(:presentation (make-presentation ,model :type :one-line)))))
  93                   (meta-model:list-has-many model))))
  94
  95 (defmethod set-default-attributes ((model t))
  96   (mapcar #'(lambda (x)
  97               (setf (find-attribute model (car x)) (cdr x)))
  98           (default-attributes model)))
  99
 100
 101 (defgeneric attributes-getter (model))
 102
 103 ;;;presentations
 104
 105
 106
 107
 108 (defcomponent mewa ()
 109   ((attributes
 110     :initarg :attributes
 111     :accessor attributes
 112     :initform nil)
 113    (attributes-getter
 114     :accessor attributes-getter
 115     :initform #'get-attributes
 116     :initarg :attributes-getter)
 117    (global-properties
 118     :initarg :global-properties
 119     :accessor global-properties
 120     :initform nil)
 121    (classes
 122     :initarg :classes
 123     :accessor classes
 124     :initform nil)
 125    (use-instance-class-p
 126     :initarg :use-instance-class-p
 127     :accessor use-instance-class-p
 128     :initform t)
 129    (initializedp :initform nil)
 130    (modifiedp :accessor modifiedp :initform nil)
 131    (modifications :accessor modifications :initform nil)))
 132
 133
 134 (defmethod attributes :around ((self mewa))
 135   (let ((a (call-next-method)))
 136     (or a (funcall (attributes-getter self) self))))
 137
 138 (defgeneric get-attributes (mewa))
 139
 140 (defmethod get-attributes ((self mewa))
 141   (if (instance self)
 142   (append (meta-model:list-slots (instance self))
 143           (meta-model:list-has-many (instance self)))
 144   nil))
 145
 146
 147 (defmethod find-instance-classes ((self mewa))
 148   (mapcar #'class-name
 149           (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
 150
 151 (defmethod find-all-attributes ((self mewa))
 152   (reduce #'append
 153           (mapcar #'(lambda (x)
 154                       (cdr (find-class-attributes x)))
 155                   (classes self))))
 156
 157 (defun make-attribute (&rest props &key type &allow-other-keys)
 158         (remf props :type)
 159         (cons (gensym) (cons type props)))
 160
 161
 162 (defmethod find-applicable-attributes ((self mewa))
 163   (let ((all-attributes (find-all-attributes self)))
 164     (flet ((gen-att (x) (let ((att (assoc x all-attributes)))
 165                                      (when att
 166                                        (setf (cddr att) (plist-union (global-properties self) (cddr att)))
 167                                        att))))
 168     (if (attributes self)
 169         (remove 'nil
 170                 (mapcar #'(lambda (x)
 171                             (cond
 172                              ;;simple casee
 173                              ((symbolp x)
 174                               (gen-att x))
 175                              ;;if the car is a keyword then this is an inline def
 176                              ((and (listp x) (keywordp (car x)))
 177                               (let ((att (apply #'make-attribute x)))
 178                                 (setf (cddr att)
 179                                       (plist-union (cddr att) (global-properties self)))
 180                                 att))
 181                              ;; if the plist has a :type
 182                              ((and (listp x) (getf (cdr x) :type))
 183                               (let ((new (cdr (apply #'make-attribute (cdr x))))
 184                                     (def (gen-att (car x))))
 185                                 (setf (cdr new) (plist-union (cdr new) (cddr def)))
 186                                 (cons (car def) new)))
 187                              ;;finally if we are just overiding the props
 188                              ((and (listp x) (symbolp (car x)))
 189                               (let ((new (cdr (apply #'make-attribute (cdr x))))
 190                                     (def (gen-att (car x))))
 191                                 (setf (cdr new) (plist-union (cdr new) (cddr def)))
 192                                 (cons (car def) (cons (second def) (cdr new)))))
 193
 194                               )
 195                              )
 196
 197                         (attributes self)))
 198       all-attributes))))
 199
 200 (defmethod find-slot-presentations ((self mewa))
 201   (mapcar #'(lambda (s)
 202               (let ((class-name (or (gethash (second s) ucw::*slot-type-mapping*) 'mewa-object-presentation)))
 203               (apply #'make-instance
 204                      class-name
 205                      (append (cddr s) (list :parent self)))))
 206           (find-applicable-attributes self)))
 207
 208
 209
 210 (defmethod initialize-slots ((self mewa))
 211   (when (use-instance-class-p self)
 212     (setf (classes self)
 213           (append (find-instance-classes self)
 214                   (classes self))))
 215   (setf (slots self) (find-slot-presentations   self)))
 216
 217
 218 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
 219   (let* ((p (make-instance 'mewa-object-presentation))
 220          (a (progn (setf (slot-value p 'instance) object)
 221                    (initialize-slots p)
 222                    (assoc type (find-all-attributes p))))
 223
 224          (i (apply #'make-instance (second a) (plist-union initargs (cddr a)))))
 225     (setf (slot-value i 'instance) object)
 226     i))
 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 (or (second a)
 235                                        ;; if we didnt find the type,
 236                                        ;; use the symbol as a class.
 237                                        (if (eql (symbol-package type)
 238                                                 (find-package 'keyword))
 239                                            (symbol-name type)
 240                                            type))
 241                                        (plist-union initargs (cddr a)))))
 242     (setf (slot-value i 'instance) object)
 243     (initialize-slots i)
 244     (setf (slot-value i 'initializedp) t)
 245     i))
 246
 247
 248
 249
 250
 251 (defmethod call-component :before ((from standard-component) (to mewa))
 252   (unless (slot-value to 'initializedp)
 253     (initialize-slots to))
 254   (setf (slot-value to 'initializedp) t)
 255   (setf (slots to) (mapcar #'(lambda (x) (prog2
 256                                              (setf (component.place x) (component.place from))
 257                                              x))
 258                              (slots to))))
 259
 260 (defmacro call-presentation (object &rest args)
 261   `(present-object ,object :presentation (make-presentation ,object ,@args)))
 262
 263
 264
 265 (defaction cancel-save-instance ((self mewa))
 266   (answer nil))
 267
 268 (defaction save-instance ((self mewa))
 269   (meta-modqel:sync-instance (instance self))
 270    (setf (modifiedp self) nil)
 271        (answer self))
 272
 273
 274 (defaction ok ((self mewa) &optional arg)
 275   "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
 276   (declare (ignore arg))
 277   (when (modifiedp self)
 278     (let ((message (format nil "Record has been modified, Do you wish to save the changes?<br/> ~a" (print (modifications self)))))
 279       (case (call 'option-dialog
 280                   :message message
 281                   :options '((:save . "Save changes to Database")
 282                              (:cancel . "Cancel all changes")))
 283         (:cancel
 284          (cancel-save-instance self))
 285         (:save
 286          (save-instance self)))))
 287   (answer self))
 288
 289
 290
 291 (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
 292   (let* ((old (prog1
 293                  (presentation-slot-value slot instance)
 294                (call-next-method)))
 295         (new (presentation-slot-value slot instance)))
 296
 297   (unless (equal new old )
 298     (let ((self (ucw::parent slot)))
 299       (setf (modifiedp self) instance
 300             (modifications self)  (append (list  (type-of new) (type-of old) (type-of value) slot instance )))))))