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