src/mewa.lisp

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