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
 281
 282 (defaction cancel-save-instance ((self mewa))
 283   (cond
 284     ((slot-value (instance self) 'clsql-sys::view-database)
 285       (meta-model::update-instance-from-records (instance self))
 286       (answer self))
 287     (t (answer nil))))
 288
 289 (defaction save-instance ((self mewa))
 290   (meta-model:sync-instance (instance self))
 291    (setf (modifiedp self) nil)
 292        (answer self))
 293
 294
 295 (defaction ok ((self mewa) &optional arg)
 296   "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
 297   (declare (ignore arg))
 298   (when (modifiedp self)
 299     (let ((message (format nil "Record has been modified, Do you wish to save the changes?<br/> ~a" (print (modifications self)))))
 300       (case (call 'option-dialog
 301                   :message message
 302                   :options '((:save . "Save changes to Database")
 303                              (:cancel . "Cancel all changes")))
 304         (:cancel
 305          (cancel-save-instance self))
 306         (:save
 307          (save-instance self)))))
 308   (answer self))
 309
 310
 311
 312 (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
 313   (let* ((old (prog1
 314                  (presentation-slot-value slot instance)
 315                (call-next-method)))
 316         (new (presentation-slot-value slot instance)))
 317
 318   (unless (equal new old )
 319     (let ((self (ucw::parent slot)))
 320       (setf (modifiedp self) instance
 321             (modifications self)  (append (list  (type-of new) (type-of old) (type-of value) slot instance )))))))
 322
 323
 324 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.
 325 ;; You are granted the rights to distribute
 326 ;; and use this software as governed by the terms
 327 ;; of the Lisp Lesser GNU Public License
 328 ;; (http://opensource.franz.com/preamble.html),
 329 ;; known as the LLGPL.