src/mewa/mewa.lisp

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