src/mewa.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (defun persistentp (object)
   4   (slot-value object 'clsql-sys::view-database))
   5
   6 (define-layered-class description ()
   7   ((description-type
   8     :initarg :type
   9     :accessor description-type
  10     :initform 'viewer
  11     :special t)
  12    (description-layers
  13     :initarg :layers
  14     :accessor description-layers
  15     :initform nil
  16     :special t)
  17    (described-object
  18     :layered-accessor object
  19     :initform nil
  20     :special t)
  21    (description-default-attributes
  22     :accessor default-attributes
  23     :initarg :default-attributes
  24     :initform nil
  25     :special t)
  26    (description-attributes
  27     :accessor attributes
  28     :initarg :attributes
  29     :initform nil
  30     :special t)
  31    (description-properties
  32     :accessor description-properties
  33     :initarg :properties
  34     :initform '()
  35     :special t)
  36    (description-default-properties
  37     :accessor default-properties
  38     :initarg :default-properties
  39     :initform '()
  40     :special t)))
  41
  42 (defmethod attributes :around ((description description))
  43   "Add any default properties to the attributes"
  44
  45   (let ((default-properties (default-properties description)))    (if (and (listp default-properties)
  46              (not (null default-properties)))
  47         (let ((a (mapcar #'(lambda (att)
  48                     (append (ensure-list att) default-properties))
  49                 (call-next-method))))
  50
  51
  52           a)
  53         (call-next-method))))
  54
  55 (defmethod print-object ((self description) stream)
  56   (print-unreadable-object (self stream :type t)
  57     (with-slots (description-type) self
  58       (format stream "~A" description-type))))
  59
  60 ;;;; * Occurences
  61
  62 (defvar *occurence-map* (make-hash-table)
  63   "a display is generated by associating an 'occurence'
  64 with an instance of a class. This is usually keyed off class-name,
  65 although an arbitrary occurence could be used with an arbitrary class.")
  66
  67 (define-layered-class
  68     standard-occurence (description)
  69     ((occurence-name :accessor name :initarg :name)
  70      (attribute-map :accessor attribute-map :initform (make-hash-table)))
  71     (:documentation
  72      "an occurence holds the attributes like a class holds slot-definitions.
  73 Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."))
  74
  75 (defun find-or-create-occurence (name)
  76   "Returns the occurence associated with this name."
  77   (or (get-occurence name)
  78       (values (setf (get-occurence name) (make-instance 'standard-occurence :name name))
  79               t)))
  80
  81 (defun get-occurence (name)
  82   (gethash name *occurence-map*))
  83
  84 (defun (setf get-occurence) (occurence name)
  85     (setf (gethash name *occurence-map*) occurence))
  86
  87 (defun clear-occurence (occurence)
  88   "removes all attributes from the occurence"
  89   (setf (attribute-map occurence) (make-hash-table)))
  90
  91 (defmethod make-attribute-using-slot-definition (slotd)
  92   (make-attribute
  93    :name (closer-mop:slot-definition-name slotd)
  94    :type-spec (closer-mop:slot-definition-type slotd)
  95    :type (first (remove-if (lambda (item)
  96                              (or
  97                               (eql item 'or)
  98                               (eql item 'null)
  99                               (eql item nil)))
 100                            (ensure-list (closer-mop:slot-definition-type slotd))))))
 101
 102 (defmethod initialize-occurence-for-instance (occurence instance)
 103   (let ((slots (closer-mop:class-slots (class-of instance))))
 104     (dolist (s slots)
 105       (let ((att (make-attribute-using-slot-definition s)))
 106         (setf (find-attribute occurence (attribute-name att)) att)))
 107     occurence))
 108
 109 (defgeneric find-occurence (name)
 110   (:method (thing)
 111     nil)
 112   (:method ((name symbol))
 113     (find-or-create-occurence name))
 114   (:method ((instance standard-object))
 115     (multiple-value-bind (occ new?)
 116         (find-or-create-occurence (class-name-of instance))
 117       (if new?
 118           (initialize-occurence-for-instance occ instance)
 119           occ))))
 120
 121 (defun list-attributes (occurence)
 122   (let (res)
 123     (maphash (lambda (k v)
 124                (declare (ignore v))
 125                (push k res))
 126              (attribute-map occurence))
 127     res))
 128
 129
 130 (define-layered-class
 131     attribute (description)
 132     ((attribute-name :layered-accessor attribute-name
 133            :initarg :name
 134            :initform (gensym "ATTRIBUTE-")
 135            :special t)
 136      (occurence :accessor occurence :initarg :occurence :initform nil)
 137      (label :initarg :label :layered-accessor label :initform nil :special t)))
 138
 139
 140 ;;;; * Attributes
 141 (defmethod print-object ((self attribute) stream)
 142   (print-unreadable-object (self stream :type t)
 143     (with-slots (attribute-name description-type) self
 144       (format stream "~A ~A" description-type attribute-name))))
 145
 146 (define-layered-class
 147     standard-attribute (attribute)
 148     ((setter :accessor setter :initarg :setter :special t :initform nil)
 149      (getter :accessor getter :initarg :getter :special t :initform nil)
 150      (value :accessor value :initarg :value :special t)
 151      (slot-name :accessor slot-name :initarg :slot-name :special t :initform nil)
 152      (typespec :accessor type-spec :initarg :type-spec :initform nil))
 153     (: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."))
 154
 155 (define-layered-method label :around ((attribute standard-attribute))
 156  (or (call-next-method) (attribute-name attribute)))
 157
 158 (defmacro defattribute (name supers slots &rest args)
 159   (let* (
 160         (type-provided-p (second (assoc :type-name args)))
 161         (type (or type-provided-p name))
 162         (layer (or (second (assoc :in-layer args)) nil))
 163         (properties (cdr (assoc :default-properties args)))
 164         (cargs (remove-if #'(lambda (key)
 165                    (or (eql key :type-name)
 166                        (eql key :default-properties)
 167                        (eql key :default-initargs)
 168                        (eql key :in-layer)))
 169                          args
 170                :key #'car)))
 171
 172     `(progn
 173       (define-layered-class
 174           ;;;; TODO: fix the naive way of making sure s-a is a superclass
 175           ;;;; Need some MOPey goodness.
 176           ,name ,@ (when layer `(:in-layer ,layer)),(or supers '(standard-attribute))
 177           ,(append slots (properties-as-slots properties))
 178           #+ (or) ,@ (cdr cargs)
 179           ,@cargs
 180           (:default-initargs :properties (list ,@properties)
 181             ,@ (cdr (assoc :default-initargs args))))
 182
 183       ,(when (or
 184              type-provided-p
 185              (not (find-attribute-class-for-type name)))
 186          `(defmethod find-attribute-class-for-type ((type (eql ',type)))
 187            ',name)))))
 188
 189 (defun clear-attributes (name)
 190   "removes all attributes from an occurance"
 191   (clear-occurence (find-occurence name)))
 192
 193 (defmethod find-attribute-class-for-type (type)
 194   nil)
 195
 196 (defun make-attribute (&rest args &key type &allow-other-keys)
 197   (apply #'make-instance
 198          (or (find-attribute-class-for-type type)
 199              'standard-attribute)
 200          :properties args
 201          args))
 202
 203 (defmethod ensure-attribute ((occurence standard-occurence) &rest args &key name &allow-other-keys)
 204   "Creates an attribute in the given occurence"
 205   (let ((attribute (apply #'make-attribute :occurence occurence args)))
 206     (setf (find-attribute occurence name) attribute)))
 207
 208 (defmethod find-attribute ((occurence null) name)
 209   nil)
 210
 211 (defmethod find-attribute ((occurence standard-occurence) name)
 212   (or (gethash name (attribute-map occurence))
 213       (let* ((class (ignore-errors (find-class (name occurence))))
 214              (class-direct-superclasses
 215               (when class
 216                 (closer-mop:class-direct-superclasses
 217                  class))))
 218         (when class-direct-superclasses
 219           (let ((attribute
 220                  (find-attribute
 221                   (find-occurence (class-name
 222                                    (car
 223                                     class-direct-superclasses)))
 224                   name)))
 225             attribute)))))
 226
 227 (defmethod find-all-attributes ((occurence standard-occurence))
 228   (loop for att being the hash-values of (attribute-map occurence)
 229      collect att))
 230
 231 (defmethod ensure-attribute (occurence-name &rest args &key name type &allow-other-keys)
 232   (declare (ignore name type))
 233   (apply #'ensure-attribute
 234    (find-occurence occurence-name)
 235    args))
 236
 237 ;;;; The following functions make up the public interface to the
 238 ;;;; MEWA Attribute Occurence system.
 239
 240 (defmethod find-all-attributes (occurence-name)
 241   (find-all-attributes (find-occurence occurence-name)))
 242
 243 (defmethod find-attribute (occurence-name attribute-name)
 244   "Return the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name"
 245   (find-attribute (find-occurence occurence-name) attribute-name))
 246
 247 (defmethod (setf find-attribute) ((attribute-spec list) occurence-name attribute-name)
 248   "Create a new attribute in the occurence.
 249 ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
 250   (apply #'ensure-attribute occurence-name :name attribute-name :type (first attribute-spec) (rest attribute-spec)))
 251
 252 (defmethod (setf find-attribute) ((attribute standard-attribute) occurence attribute-name)
 253   "Create a new attribute in the occurence.
 254 ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
 255   (setf (gethash attribute-name (attribute-map occurence))
 256           attribute))
 257
 258 (defmethod (setf find-attribute) ((attribute null) occurence attribute-name)
 259   "Create a new attribute in the occurence.
 260 ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
 261   (setf (gethash attribute-name (attribute-map occurence))
 262           attribute))
 263
 264 (defmethod find-attribute ((attribute-with-occurence attribute) attribute-name)
 265   (find-attribute (occurence attribute-with-occurence) attribute-name))
 266
 267 (defmethod set-attribute-properties ((occurence-name t) attribute properties)
 268   (setf (description-properties attribute) (plist-nunion
 269                                             properties
 270                                             (description-properties attribute)))
 271   (loop for (initarg value) on (description-properties attribute)
 272               by #'cddr
 273               with map = (initargs.slot-names attribute)
 274               do (let ((s-n (assoc-if #'(lambda (x) (member initarg x)) map)))
 275
 276                    (if s-n
 277                        (progn
 278                          (setf (slot-value attribute
 279                                            (cdr s-n))
 280                                value))
 281                        (warn "Cannot find initarg ~A in attribute ~S" initarg attribute)))
 282               finally (return attribute)))
 283
 284 (defmethod set-attribute (occurence-name attribute-name attribute-spec &key (inherit t))
 285   "If inherit is T, sets the properties of the attribute only, unless the type has changed.
 286 otherwise, (setf find-attribute)"
 287   (let ((att (find-attribute occurence-name attribute-name)))
 288     (if (and att inherit (or (eql (car attribute-spec)
 289                               (description-type att))
 290                              (eq (car attribute-spec) t)))
 291         (set-attribute-properties occurence-name att (cdr attribute-spec))
 292         (setf (find-attribute occurence-name attribute-name)
 293               (cons  (car attribute-spec)
 294                      (plist-nunion
 295                       (cdr attribute-spec)
 296                       (when att (description-properties att))))))))
 297
 298 (defmethod perform-define-attributes ((occurence-name t) attributes)
 299   (loop for attribute in attributes
 300         do (destructuring-bind (name type &rest args)
 301                   attribute
 302              (cond ((not (null type))
 303                     ;;set the type as well
 304                     (set-attribute occurence-name name (cons type args)))))))
 305
 306 (defmacro define-attributes (occurence-names &body attribute-definitions)
 307   `(progn
 308     ,@(loop for occurence-name in occurence-names
 309             collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions)))))
 310
 311
 312 (defmethod find-description (object type)
 313   (let ((occurence (find-occurence object)))
 314         occurence))
 315
 316 ;;"Unused???"
 317 (defmethod setter (attribute)
 318   (warn "Setting ~A in ~A" attribute *context*)
 319   (let ((setter (getf (description-properties attribute) :setter))
 320         (slot-name (getf (description-properties attribute) :slot-name)))
 321     (cond (setter
 322            setter)
 323           (slot-name
 324            #'(lambda (value object)
 325                (setf (slot-value object slot-name) value)))
 326           (t
 327            #'(lambda (value object)
 328                (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute))))))
 329
 330
 331 (define-layered-function attribute-value (instance attribute)
 332   (:documentation " Like SLOT-VALUE for instances, the base method calls GETTER."))
 333
 334 (defmethod attribute-slot-value (instance attribute)
 335   "Return (VALUES slot-value-or-nil existsp boundp
 336
 337 If this attribute, in its current context, refers to a slot,
 338 we return slot-value-or nil either boundp or not."
 339   (let (existsp boundp slot-value-or-nil)
 340     (cond
 341       ((and (slot-boundp attribute 'slot-name) (slot-name attribute))
 342          (when (slot-exists-p instance (slot-name attribute))
 343            (setf existsp t)
 344            (when (slot-boundp instance (slot-name attribute))
 345              (setf boundp t
 346                    slot-value-or-nil (slot-value
 347                                       instance
 348                                       (slot-name attribute))))))
 349         ((and (slot-exists-p instance (attribute-name attribute)))
 350          (setf existsp t)
 351          (when (slot-boundp instance (attribute-name attribute))
 352            (setf boundp t
 353                  slot-value-or-nil (slot-value
 354                                     instance
 355                                     (attribute-name attribute))))))
 356     (VALUES slot-value-or-nil existsp boundp)))
 357
 358 (define-layered-method attribute-value (instance (attribute standard-attribute))
 359  "return the attribute value or NIL if it cannot be found"
 360     (with-slots (getter value) attribute
 361       (when (slot-boundp attribute 'value)
 362         (setf getter (constantly value)))
 363       (if (and (slot-boundp attribute 'getter) getter)
 364           ;;;; call the getter
 365           (funcall getter instance)
 366           ;;;; or default to the attribute-slot-value
 367           (attribute-slot-value instance attribute))))
 368
 369 (define-layered-function (setf attribute-value) (value instance attribute))
 370
 371 (define-layered-method
 372     (setf attribute-value) (value instance (attribute standard-attribute))
 373   (with-slots (setter slot-name) attribute
 374     (cond ((and (slot-boundp attribute 'setter) setter)
 375            (funcall setter value instance))
 376           ((and (slot-boundp attribute 'slot-name) slot-name)
 377            (setf (slot-value instance slot-name) value))
 378           ((and (slot-exists-p instance (attribute-name attribute)))
 379            (setf (slot-value instance (attribute-name attribute)) value))
 380           (t
 381            (error "Cannot set ~A in ~A" attribute instance)))))
 382
 383
 384
 385 ;;;; ** Default Attributes
 386 ;;;; TODO: This is mosty an ugly hack and should be reworked.
 387 ;;;;
 388 ;;;; The default mewa class contains the types use as defaults.
 389 ;;;; maps meta-model slot-types to slot-presentation
 390
 391 (defvar *default-attributes-class-name* 'default)
 392
 393 (defmacro with-default-attributes ((occurence-name) &body body)
 394   `(let ((*default-attributes-class-name* ',occurence-name))
 395     ,@body))
 396
 397 (define-attributes (default)
 398   (boolean boolean)
 399   (string string)
 400   (number currency)
 401   (integer   integer)
 402   (currency  currency)
 403   (clsql:generalized-boolean boolean)
 404   (foreign-key has-a))
 405
 406 (defun attribute-to-definition (attribute)
 407   (nconc (list (attribute-name attribute)
 408                (description-type attribute))
 409          (description-properties attribute)))
 410
 411 (defun find-default-presentation-attribute-definitions ()
 412   nil)
 413
 414 (defun gen-ptype (type)
 415   (let* ((type (if (consp type) (car type) type))
 416          (possible-default (find-attribute *default-attributes-class-name* type))
 417          (real-default (find-attribute 'default type)))
 418     (cond
 419       (possible-default
 420         (description-type possible-default))
 421        (real-default
 422         (description-type real-default))
 423        (t type))))
 424
 425 (defun gen-presentation-slots (instance)
 426   (mapcar #'(lambda (x) (gen-pslot (cadr x)
 427                                    (string (car x))
 428                                    (car x)))
 429           (meta-model:list-slot-types instance)))
 430
 431
 432 (defun gen-pslot (type label slot-name)
 433   (copy-list `(,(gen-ptype type)
 434                :label ,label
 435                :slot-name ,slot-name)))
 436
 437 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.