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