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