| 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. |