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