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