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