src/mewa.lisp

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