src/mewa/mewa.lisp

   1 (in-package :mewa)
   2
   3 (defparameter *default-type* :ucw)
   4
   5 ;;; maps meta-model slot-types to slot-presentation
   6 (defparameter *slot-type-map* '(number ucw:currency))
   7
   8 ;;; an alist of model-class-name . attributes
   9 ;;; should really be a hash-table.
  10 (defvar *attribute-map* (list))
  11
  12 ;;; some utilities for merging plists
  13
  14 (defun plist-nunion (new-props plist)
  15   (loop for cons on new-props
  16         for i from 1
  17         when (oddp i)
  18         do (setf (getf plist (first cons)) (second cons))
  19         finally (return plist)))
  20
  21 (defun plist-union (new-props plist)
  22   "Non-destructive version of plist-nunion"
  23                    (plist-nunion new-props (copy-list plist)))
  24
  25 (defun gen-ptype (type)
  26   (or (getf *slot-type-map* type) type))
  27
  28 (defun gen-presentation-slots (instance)
  29   (mapcar #'(lambda (x) (gen-pslot (cadr x)
  30                                    (string (car x))
  31                                    (car x)))
  32           (list-slot-types instance)))
  33
  34
  35 (defun gen-pslot (type label slot-name)
  36   (copy-list `(,(gen-ptype type)
  37                :label ,label
  38                :slot-name ,slot-name)))
  39
  40 (defun gen-presentation-args (instance args)
  41   (declare (ignore instance))
  42   (if args args nil))
  43
  44
  45 (defun find-or-create-attributes (class-name)
  46   "return an exisiting class attribute map or create one.
  47
  48 A map is a cons of class-name . attributes.
  49 attributes is an alist keyed on the attribute nreeame."
  50   (or (assoc class-name *attribute-map*)
  51       (progn
  52         (setf *attribute-map* (acons class-name (list (list)) *attribute-map*))
  53         (assoc class-name *attribute-map*))))
  54
  55 (defgeneric find-class-attributes (class))
  56
  57 (defmethod find-class-attributes ((model t))
  58   (find-or-create-attributes (class-name (class-of model))))
  59
  60 (defmethod find-class-attributes ((model symbol))
  61   (find-or-create-attributes model))
  62
  63 (defmethod add-attribute ((model t) name def)
  64   (let ((map (find-class-attributes model)))
  65     (setf (cdr map) (acons name def (cdr map)))))
  66
  67 (defmethod find-attribute ((model t) name)
  68   (assoc name (cdr (find-class-attributes model))))
  69
  70 (defmethod (setf find-attribute) ((def list) (model t) name)
  71   (let ((attr (find-attribute model name)))
  72     (if attr
  73         (prog2
  74             (setf (cdr attr) def)
  75             attr)
  76         (prog2
  77             (add-attribute model name def)
  78             (find-attribute model name)))))
  79
  80 (defmethod set-attribute ((model t) name definition &key (inherit t))
  81   (setf (find-attribute model name)
  82         (if inherit
  83             (cons (car definition)
  84                   (plist-union (cdr definition)
  85                          (cddr (find-attribute model name))))
  86             definition)))
  87
  88
  89 (defmethod default-attributes ((model t))
  90   (append (mapcar #'(lambda (s) (cons (car s) (gen-pslot (if (meta-model:foreign-key-p model (car s))
  91                                                    'ucw::foreign-key
  92                                                    (cadr s))
  93                                                  (string (car s)) (car s))))
  94           (meta-model:list-slot-types model))
  95           (mapcar #'(lambda (s) (cons s (append (gen-pslot 'ucw::has-many (string s) s) `(:presentation (make-presentation ,model :type :one-line)))))
  96                   (meta-model:list-has-many model))))
  97
  98 (defmethod set-default-attributes ((model t))
  99   (mapcar #'(lambda (x)
 100               (setf (find-attribute model (car x)) (cdr x)))
 101           (default-attributes model)))
 102
 103
 104 (defgeneric attributes-getter (model))
 105
 106 ;;;presentations
 107
 108
 109
 110
 111 (defcomponent mewa ()
 112   ((attributes
 113     :initarg :attributes
 114     :accessor attributes
 115     :initform nil)
 116    (attributes-getter
 117     :accessor attributes-getter
 118     :initform #'get-attributes
 119     :initarg :attributes-getter)
 120    (global-properties
 121     :initarg :global-properties
 122     :accessor global-properties
 123     :initform nil)
 124    (classes
 125     :initarg :classes
 126     :accessor classes
 127     :initform nil)
 128    (use-instance-class-p
 129     :initarg :use-instance-class-p
 130     :accessor use-instance-class-p
 131     :initform t)
 132    (initializedp :initform nil)
 133    (modifiedp :accessor modifiedp :initform nil)))
 134
 135
 136 (defmethod attributes :around ((self mewa))
 137   (let ((a (call-next-method)))
 138     (or a (funcall (attributes-getter self) self))))
 139
 140 (defgeneric get-attributes (mewa))
 141
 142 (defmethod get-attributes ((self mewa))
 143   (if (instance self)
 144   (append (meta-model:list-slots (instance self))
 145           (meta-model:list-has-many (instance self)))
 146   nil))
 147
 148
 149 (defmethod find-instance-classes ((self mewa))
 150   (mapcar #'class-name
 151           (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
 152
 153 (defmethod find-all-attributes ((self mewa))
 154   (reduce #'append
 155           (mapcar #'(lambda (x)
 156                       (cdr (find-class-attributes x)))
 157                   (classes self))))
 158
 159 (defun make-attribute (&rest props &key type &allow-other-keys)
 160         (remf props :type)
 161         (cons (gensym) (cons type props)))
 162
 163
 164 (defmethod find-applicable-attributes ((self mewa))
 165   (let ((all-attributes (find-all-attributes self)))
 166     (flet ((gen-att (x) (let ((att (assoc x all-attributes)))
 167                                      (when att
 168                                        (setf (cddr att) (plist-union (global-properties self) (cddr att)))
 169                                        att))))
 170     (if (attributes self)
 171         (remove 'nil
 172                 (mapcar #'(lambda (x)
 173                             (cond
 174                              ;;simple casee
 175                              ((symbolp x)
 176                               (gen-att x))
 177                              ;;if the car is a keyword then this is an inline def
 178                              ((and (listp x) (keywordp (car x)))
 179                               (let ((att (apply #'make-attribute x)))
 180                                 (setf (cddr att)
 181                                       (plist-union (cddr att) (global-properties self)))
 182                                 att))
 183                              ;; if the plist has a :type
 184                              ((and (listp x) (getf (cdr x) :type))
 185                               (let ((new (cdr (apply #'make-attribute (cdr x))))
 186                                     (def (gen-att (car x))))
 187                                 (setf (cdr new) (plist-union (cdr new) (cddr def)))
 188                                 (cons (car def) new)))
 189                              ;;finally if we are just overiding the props
 190                              ((and (listp x) (symbolp (car x)))
 191                               (let ((new (cdr (apply #'make-attribute (cdr x))))
 192                                     (def (gen-att (car x))))
 193                                 (setf (cdr new) (plist-union (cdr new) (cddr def)))
 194                                 (cons (car def) (cons (second def) (cdr new)))))
 195
 196                               )
 197                              )
 198
 199                         (attributes self)))
 200       all-attributes))))
 201
 202 (defmethod find-slot-presentations ((self mewa))
 203   (mapcar #'(lambda (s)
 204               (let ((class-name (or (gethash (second s) ucw::*slot-type-mapping*) 'mewa-object-presentation)))
 205               (apply #'make-instance
 206                      class-name
 207                      (append (cddr s) (list :parent self)))))
 208           (find-applicable-attributes self)))
 209
 210
 211
 212 (defmethod initialize-slots ((self mewa))
 213   (when (use-instance-class-p self)
 214     (setf (classes self)
 215           (append (find-instance-classes self)
 216                   (classes self))))
 217   (setf (slots self) (find-slot-presentations   self)))
 218
 219
 220 (defmethod render-on :around ((res response) (self mewa))
 221   (unless (slot-value self 'initializedp)
 222     (initialize-slots self))
 223   (setf (slot-value self 'initializedp) t)
 224   (call-next-method))
 225
 226
 227 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
 228   (let* ((p (make-instance 'mewa-object-presentation))
 229          (a (progn (setf (slot-value p 'instance) object)
 230                    (initialize-slots p)
 231                    (assoc type (find-all-attributes p))))
 232
 233          (i (apply #'make-instance (second a) (plist-union initargs (cddr a)))))
 234     (setf (slot-value i 'instance) object)
 235     i))
 236
 237 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
 238   (let* ((p (make-instance 'mewa-object-presentation))
 239          (a (progn (setf (slot-value p 'instance) object)
 240                    (initialize-slots p)
 241                    (assoc type (find-all-attributes p))))
 242
 243          (i (apply #'make-instance (or (second a)
 244                                        ;; if we didnt find the type,
 245                                        ;; use the symbol as a class.
 246                                        (if (eql (symbol-package type)
 247                                                 (find-package 'keyword))
 248                                            (symbol-name type)
 249                                            type))
 250                                        (plist-union initargs (cddr a)))))
 251     (setf (slot-value i 'instance) object)
 252     i))
 253
 254
 255
 256
 257
 258 (defmethod call-component :before ((from standard-component) (to mewa))
 259   (unless (slot-value to 'initializedp)
 260     (initialize-slots to))
 261   (setf (slot-value to 'initializedp) t)
 262   (setf (slots to) (mapcar #'(lambda (x) (prog2
 263                                              (setf (component.place x) (component.place from))
 264                                              x))
 265                              (slots to))))
 266
 267 (defmacro call-presentation (object &rest args)
 268   `(present-object ,object :presentation (make-presentation ,object ,@args)))