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