src/mewa.lisp

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