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