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