src/mewa.lisp

   1 (declaim (optimize (speed 2) (space 3) (safety 0)))
   2
   3 (in-package :lisp-on-lines)
   4
   5 (defparameter *default-type* :ucw)
   6
   7 ;;;; I think these are unused now
   8 (defmethod perform-set-attributes ((occurence-name t) definitions)
   9   (dolist (def definitions)
  10     (funcall #'set-attribute occurence-name (first def) (rest def))))
  11
  12 (defmethod perform-set-attribute-properties ((occurence-name t) definitions)
  13   (dolist (def definitions)
  14     (funcall #'set-attribute-properties occurence-name (car def) (cdr def))))
  15
  16 ;;;; PLIST Utilities.
  17
  18 (defun plist-nunion (new-props plist)
  19   "Destructive Merge of plists. PLIST is modified and returned.
  20 NEW-PROPS is merged into PLIST such that any properties
  21 in both PLIST and NEW-PROPS get the value in NEW-PROPS.
  22 The other properties in PLIST are left untouched."
  23   (loop for cons on new-props by #'cddr
  24         do (setf (getf plist (first cons)) (second cons))
  25         finally (return plist))
  26   plist)
  27
  28 (defun plist-union (new-props plist)
  29   "Non-destructive version of plist-nunion"
  30                    (plist-nunion new-props (copy-list plist)))
  31
  32
  33 ;;;; * Occurences
  34
  35 (defvar *occurence-map* (make-hash-table)
  36   "Presentations are created by associating an 'occurence'
  37 with an instance of a class. This is usually keyed off class-name,
  38 although an arbitrary occurence can be used with an arbitrary class.")
  39
  40 (define-layered-class
  41     standard-occurence ()
  42     ((attribute-map :accessor attribute-map :initform (make-hash-table)))
  43     (:documentation
  44      "an occurence holds the attributes like a class holds slot-definitions.
  45 Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."))
  46
  47 (defun find-or-create-occurence (name)
  48   "Returns the occurence associated with this name."
  49   (let ((occurence (gethash name *occurence-map*)))
  50     (if occurence
  51         occurence
  52         (let ((new-occurence (make-instance 'standard-occurence)))
  53           (setf (gethash name *occurence-map*) new-occurence)
  54           new-occurence))))
  55
  56 (defun clear-occurence (occurence)
  57   "removes all attributes from the occurence"
  58   (setf (attribute-map occurence) (make-hash-table)))
  59
  60 (defgeneric find-occurence (name)
  61   (:method (thing)
  62     nil)
  63   (:method ((name symbol))
  64     (find-or-create-occurence name))
  65   (:method ((instance standard-object))
  66     (find-or-create-occurence (class-name (class-of instance)))))
  67
  68
  69 ;;;; * Attributes
  70
  71 (define-layered-class
  72     standard-attribute ()
  73     ((name :layered-accessor attribute.name :initarg :name :initform "attribute")
  74      (type :layered-accessor attribute.type :initarg :type :initform t :type symbol)
  75      (plist :layered-accessor attribute.plist :initarg :plist :initform nil))
  76     (:documentation "Attributes are used to display a part of a thing, such as a slot of an object, a text label, the car of a list, etc."))
  77
  78 (defmacro defattribute (name supers slots &rest args)
  79   (let ((type (or (second (assoc :type-name args)) name))
  80         (properties (cdr (assoc :default-properties args))))
  81     `(progn
  82
  83       (define-layered-class
  84           ;;;; TODO: fix the naive way of making sure s-a is a superclass
  85           ,name ,(or supers '(standard-attribute))
  86           ,slots
  87           #+ (or) ,@ (cdr args)
  88           (:default-initargs :plist (list ,@properties)))
  89       (defmethod find-attribute-class-for-type ((type (eql ',type)))
  90         ',name))))
  91
  92 (defmethod print-object ((self standard-attribute) stream)
  93   (print-unreadable-object (self stream :type t)
  94     (with-slots (name type) self
  95       (format stream "~A ~A" name type))))
  96
  97 (define-layered-class
  98     presentation-attribute (standard-attribute)
  99     ()
 100     (:documentation "Presentation Attributes are used to display objects
 101 using the attributes defined in an occurence. Presentation Attributes are always named using keywords."))
 102
 103 (defun clear-attributes (name)
 104   "removes all attributes from an occurance"
 105   (clear-occurence (find-occurence name)))
 106
 107 (defmethod find-attribute-class-for-type (type)
 108   nil)
 109
 110 (defmethod find-attribute-class-for-name (name)
 111   "presentation attributes are named using keywords"
 112   (if (keywordp name)
 113       'presentation-attribute
 114       'standard-attribute))
 115
 116 (defun make-attribute (&key name type plist)
 117   (let ((i (make-instance (or (find-attribute-class-for-type type)
 118                      (find-attribute-class-for-name name))
 119                  :name name :type type)))
 120     (setf (attribute.plist i)
 121           (plist-union plist (attribute.plist i)))
 122     i))
 123
 124 (defmethod ensure-attribute ((occurence standard-occurence) name type plist)
 125   "Creates an attribute in the given occurence"
 126   (setf (gethash name (attribute-map occurence))
 127         (make-attribute :name name :type type :plist plist)))
 128
 129 (defmethod find-attribute ((occurence standard-occurence) name)
 130   (gethash name (attribute-map occurence)))
 131
 132 (defmethod find-all-attributes ((occurence standard-occurence))
 133   (loop for att being the hash-values of (attribute-map occurence)
 134         collect att))
 135
 136 (defmethod ensure-attribute (occurence-name name type plist)
 137   (ensure-attribute
 138    (find-occurence occurence-name)
 139    name
 140    type
 141    plist))
 142
 143 ;;;; The following functions make up the public interface to the
 144 ;;;; MEWA Attribute Occurence system.
 145
 146 (defmethod find-all-attributes (occurence-name)
 147   (find-all-attributes (find-occurence occurence-name)))
 148
 149 (defmethod find-attribute (occurence-name attribute-name)
 150   "Returns the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name"
 151   (find-attribute (find-occurence occurence-name) attribute-name))
 152
 153 (defmethod (setf find-attribute) ((def list) occurence-name attribute-name)
 154   (ensure-attribute occurence-name attribute-name (first def) (rest def)))
 155
 156 (defmethod set-attribute (occurence-name attribute-name definition &key (inherit t))
 157   (let ((att (find-attribute occurence-name attribute-name)))
 158       (setf (find-attribute occurence-name attribute-name)
 159         (if (and att inherit)
 160             (cons (car definition)
 161                   (plist-union (cdr definition)
 162                          (attribute.plist att)))
 163             definition))))
 164
 165 (defmethod set-attribute-properties ((occurence-name t) attribute properties)
 166   (let ((a (find-attribute occurence-name attribute)))
 167     (if a
 168         (setf (attribute.plist a) (plist-nunion properties (attribute.plist a)))
 169         (error "Attribute ~A does not exist" attribute))))
 170
 171 (defmethod perform-define-attributes ((occurence-name t) attributes)
 172   (loop for attribute in attributes
 173         do (destructuring-bind (name type &rest args)
 174                   attribute
 175                 (cond ((eq type t)
 176                        ;;use the existing (default) type
 177                        (set-attribute-properties occurence-name name args))
 178                       ((not (null type))
 179                        ;;set the type as well
 180                        (set-attribute occurence-name name (cons type args)))))))
 181
 182 (defmacro define-attributes (occurence-names &body attribute-definitions)
 183   `(progn
 184     ,@(loop for occurence-name in occurence-names
 185             collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions)))))
 186
 187
 188 (defmethod setter (attribute)
 189   (warn "Setting ~A in ~A" attribute *context*)
 190   (let ((setter (getf (attribute.plist attribute) :setter))
 191         (slot-name (getf (attribute.plist attribute) :slot-name)))
 192     (cond (setter
 193            setter)
 194           (slot-name
 195            #'(lambda (value object)
 196                (setf (slot-value object slot-name) value)))
 197           (t
 198            #'(lambda (value object)
 199              (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute))))))
 200
 201 (defmethod getter (attribute)
 202   (let ((getter (getf (attribute.plist attribute) :getter))
 203         (slot-name (getf (attribute.plist attribute) :slot-name)))
 204     (cond (getter
 205            getter)
 206           (slot-name
 207            #'(lambda (object)
 208                (when (slot-boundp object slot-name)
 209                  (slot-value object slot-name)))))))
 210
 211
 212 (define-layered-function attribute-value (instance attribute)
 213   (:documentation " Like SLOT-VALUE for instances, the base method calls GETTER."))
 214
 215 (define-layered-method attribute-value (instance (attribute standard-attribute))
 216   (funcall (getter attribute) instance))
 217
 218 (define-layered-function (setf attribute-value)  (value instance attribute))
 219
 220 (define-layered-method (setf attribute-value) (value instance (attribute standard-attribute))
 221   (funcall (setter attribute) value instance))
 222
 223
 224 ;;;; ** Default Attributes
 225
 226
 227 ;;;; The default mewa class contains the types use as defaults.
 228 ;;;; maps meta-model slot-types to slot-presentation
 229
 230 (defvar *default-attributes-class-name* 'default)
 231
 232 (defmacro with-default-attributes ((occurence-name) &body body)
 233   `(let ((*default-attributes-class-name* ',occurence-name))
 234     ,@body))
 235
 236 (define-attributes (default)
 237   (boolean mewa-boolean)
 238   (string mewa-string)
 239   (number mewa-currency)
 240   (integer   mewa-integer)
 241   (currency  mewa-currency)
 242   (clsql:generalized-boolean mewa-boolean)
 243   (foreign-key foreign-key)
 244   (:viewer mewa-viewer)
 245   (:editor mewa-editor)
 246   (:creator mewa-creator)
 247   (:as-string mewa-one-line-presentation)
 248   (:one-line mewa-one-line-presentation)
 249   (:listing mewa-list-presentation :global-properties (:editablep nil) :editablep t)
 250   (:search-model mewa-object-presentation))
 251
 252 (defun find-presentation-attributes (occurence-name)
 253   (loop for att in (find-all-attributes occurence-name)
 254         when (typep att 'presentation-attribute)
 255          collect att))
 256
 257 (defun attribute-to-definition (attribute)
 258   (nconc (list (attribute.name attribute)
 259                (attribute.type attribute))
 260          (attribute.plist attribute)))
 261
 262 (defun find-default-presentation-attribute-definitions ()
 263   (if (eql *default-attributes-class-name* 'default)
 264       (mapcar #'attribute-to-definition (find-presentation-attributes 'default))
 265       (remove-duplicates (mapcar #'attribute-to-definition
 266                                  (append
 267                                   (find-presentation-attributes 'default)
 268                                   (find-presentation-attributes
 269                                    *default-attributes-class-name*))))))
 270 (defun gen-ptype (type)
 271   (let* ((type (if (consp type) (car type) type))
 272          (possible-default (find-attribute *default-attributes-class-name* type))
 273          (real-default (find-attribute 'default type)))
 274     (cond
 275       (possible-default
 276         (attribute.type possible-default))
 277        (real-default
 278         (attribute.type real-default))
 279        (t type))))
 280
 281 (defun gen-presentation-slots (instance)
 282   (mapcar #'(lambda (x) (gen-pslot (cadr x)
 283                                    (string (car x))
 284                                    (car x)))
 285           (meta-model:list-slot-types instance)))
 286
 287
 288 (defun gen-pslot (type label slot-name)
 289   (copy-list `(,(gen-ptype type)
 290                :label ,label
 291                :slot-name ,slot-name)))
 292
 293
 294
 295 ;;;presentations
 296 (defcomponent mewa ()
 297   ((instance :accessor instance :initarg :instance)
 298    (attributes
 299     :initarg :attributes
 300     :accessor attributes
 301     :initform nil)
 302    (attributes-getter
 303     :accessor attributes-getter
 304     :initform #'get-attributes
 305     :initarg :attributes-getter)
 306    (attribute-slot-map
 307     :accessor attribute-slot-map
 308     :initform nil)
 309    (global-properties
 310     :initarg :global-properties
 311     :accessor global-properties
 312     :initform nil)
 313    (classes
 314     :initarg :classes
 315     :accessor classes
 316     :initform nil)
 317    (use-instance-class-p
 318     :initarg :use-instance-class-p
 319     :accessor use-instance-class-p
 320     :initform t)
 321    (initializedp :initform nil)
 322    (modifiedp :accessor modifiedp :initform nil :initarg :modifiedp)
 323    (modifications :accessor modifications :initform nil)))
 324
 325
 326 (defmethod attributes :around ((self mewa))
 327   (let ((a (call-next-method)))
 328     (or a (funcall (attributes-getter self) self))))
 329
 330 (defgeneric get-attributes (mewa))
 331
 332 (defmethod get-attributes ((self mewa))
 333   (if (instance self)
 334   (append (meta-model:list-slots (instance self))
 335           (meta-model:list-has-many (instance self)))
 336   nil))
 337
 338 (defmethod find-instance-classes ((self mewa))
 339   (mapcar #'class-name
 340           (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
 341
 342 (defun make-presentation-for-attribute-list-item
 343     (occurence att-name plist parent-presentation &optional type)
 344   (declare (type list plist) (type symbol att-name))
 345   "This is a ucw specific function that will eventually be factored elsewhere."
 346   (let* ((attribute (find-attribute occurence att-name))
 347          (type (when attribute (or type (attribute.type attribute))))
 348          (class-name
 349           (or (gethash (if (consp type)
 350                            (car type)
 351                            type)
 352                        *presentation-slot-type-mapping*)
 353               (error  "Can't find slot type for ~A in ~A from ~A" att-name occurence parent-presentation))))
 354
 355     (cons (attribute.name attribute) (apply #'make-instance
 356                                    class-name
 357                                    (append (plist-nunion
 358                                             plist
 359                                             (plist-union
 360                                              (global-properties parent-presentation)
 361                                              (attribute.plist attribute)))
 362                                            (list :size 30 :parent parent-presentation))))))
 363
 364 (defmethod find-applicable-attributes-using-attribute-list (occurence attribute-list)
 365   "Returns a list of functions that, when called with an object presentation,
 366 returns the ucw slot presentation that will be used to present this attribute
 367 in that object presentation."
 368     (loop for att in attribute-list
 369           with funs = (list)
 370           do (let ((att att)) (cond
 371                ;;simple casee
 372                ((symbolp att)
 373                 (push #'(lambda (p)
 374                           (make-presentation-for-attribute-list-item occurence att nil p))
 375                       funs))
 376                ;;if the car is a keyword then this is an inline def
 377                ;; drewc nov 12 2005:
 378                ;; i never used this, and never told anybody about it.
 379                ;; removing it.
 380                #+ (or) ((and (listp x) (keywordp (car x)))
 381                         (let ((att (apply #'make-attribute x)))
 382                           (setf (cddr att)
 383                                 (plist-union (cddr att) (global-properties self)))
 384                           att))
 385
 386                ;; if the plist has a :type
 387                ((and (listp att) (getf (cdr att) :type))
 388                 (let ((type (getf (cdr att) :type)))
 389                   (push #'(lambda (p)
 390                             (make-presentation-for-attribute-list-item
 391                              occurence (first att)
 392                              (cdr att)
 393                              p
 394                              type))
 395                         funs)))
 396                ;;finally if we are just overiding the props
 397                ((and (listp att) (symbolp (car att)))
 398                 (push #'(lambda (p)
 399                           (make-presentation-for-attribute-list-item occurence (first att) (rest att) p))
 400                       funs))))
 401           finally (return (nreverse funs))))
 402
 403
 404 (defun find-attribute-names (mewa)
 405   (mapcar #'(lambda (x)
 406               (if (listp x)
 407                   (first x)
 408                   x))
 409           (attributes mewa)))
 410
 411 (defmethod find-applicable-attributes ((self mewa))
 412   (if (attributes self)
 413       (find-applicable-attributes-using-attribute-list (instance self) (attributes self))
 414       (find-applicable-attributes-using-attribute-list (instance (get-attributes self)))))
 415
 416
 417 (defmethod find-slot-presentations ((self mewa))
 418   (mapcar #'(lambda (a) (funcall a self))
 419           (find-applicable-attributes self)))
 420
 421 (defmethod find-attribute-slot ((self mewa) (attribute symbol))
 422   (cdr (assoc attribute (attribute-slot-map self))))
 423
 424 (defmethod initialize-slots ((self mewa))
 425   (when (instance self)
 426     (when (use-instance-class-p self)
 427       (setf (classes self)
 428             (append (find-instance-classes self)
 429                     (classes self))))
 430     (setf (attribute-slot-map self) (find-slot-presentations self))
 431     (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self )))))
 432
 433
 434 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
 435   ;(warn "Initargs : ~A" initargs)
 436   (let* ((a (find-attribute object type))
 437          (i (apply #'make-instance
 438                    (if a
 439                        (attribute.type a)
 440                        type)
 441                    (plist-union initargs (when a
 442                                            (attribute.plist a))))))
 443
 444     (setf (slot-value i 'instance) object)
 445     (initialize-slots i)
 446     (setf (slot-value i 'initializedp) t)
 447     i))
 448
 449 (defmethod make-presentation ((list list) &key (type :listing) (initargs nil))
 450   (let ((args (append
 451                `(:type ,type)
 452                `(:initargs
 453                  (:instances ,list
 454                   ,@initargs)))))
 455
 456     (apply #'make-presentation (car list) args)))
 457
 458 (defmethod initialize-slots-place ((place ucw::place) (mewa mewa))
 459   (setf (slots mewa) (mapcar #'(lambda (x)
 460                                (prog1 x
 461                                  (setf (component.place x) place)))
 462                             (slots mewa))))
 463
 464 (arnesi:defmethod/cc call-component :before ((from standard-component) (to mewa))
 465   (unless (slot-value to 'initializedp)
 466     (initialize-slots to))
 467   (setf (slot-value to 'initializedp) t)
 468   (initialize-slots-place (component.place from) to)
 469   to)
 470
 471
 472
 473 (defmacro call-presentation (object &rest args)
 474   `(present-object ,object :presentation (make-presentation ,object ,@args)))
 475
 476
 477 (defcomponent about-dialog (option-dialog)
 478   ((body :initarg :body)))
 479
 480 (defmethod render-on ((res response) (self about-dialog))
 481   (call-next-method)
 482   (render-on res (slot-value self 'body)))
 483
 484
 485 (defaction cancel-save-instance ((self mewa))
 486   (cond
 487     ((meta-model::persistentp (instance self))
 488       (meta-model::update-instance-from-records (instance self))
 489       (answer self))
 490     (t (answer nil))))
 491
 492 (defaction save-instance ((self mewa))
 493   (meta-model:sync-instance (instance self))
 494   (setf (modifiedp self) nil)
 495   (answer self))
 496
 497 (defmethod confirm-sync-instance ((self mewa))
 498   nil)
 499
 500 (defaction ensure-instance-sync ((self mewa))
 501   (when (modifiedp self)
 502     (if nil
 503         (let ((message (format nil "Record has been modified, Do you wish to save the changes?")))
 504           (case (call 'about-dialog
 505                       :body (make-presentation (instance self)
 506                                                :type :viewer)
 507                       :message message
 508                       :options '((:save . "Save changes to Database")
 509                                  (:cancel . "Cancel all changes")))
 510             (:cancel
 511              (cancel-save-instance self))
 512             (:save
 513              (save-instance self))))
 514         (save-instance self))))
 515
 516 (defaction sync-and-answer ((self mewa))
 517   (ensure-instance-sync self)
 518   (answer (instance self)))
 519
 520 (defaction ok ((self mewa) &optional arg)
 521   "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
 522   ;(declare (ignore arg))
 523   (sync-and-answer self))
 524
 525 (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
 526   (let* ((old (prog1
 527                  (presentation-slot-value slot instance)
 528                (call-next-method)))
 529         (new (presentation-slot-value slot instance)))
 530
 531   (unless (equal new old )
 532     (let ((self (ucw::parent slot)))
 533       (setf (modifiedp self) instance
 534             (modifications self)  (append (list new old value slot instance) (modifications self)))))))
 535
 536
 537
 538
 539
 540
 541
 542 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.
 543 ;; You are granted the rights to distribute
 544 ;; and use this software as governed by the terms
 545 ;; of the Lisp Lesser GNU Public License
 546 ;; (http://opensource.franz.com/preamble.html),
 547 ;; known as the LLGPL.