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