src/meta-model.lisp

   1 (in-package :meta-model)
   2
   3 (defvar *meta-models* nil)
   4
   5 (defun list-meta-models ()
   6   *meta-models*)
   7
   8 (defclass meta-model-class ()
   9   ((metadata
  10     :accessor meta-model.metadata
  11     :initarg :metadata
  12     :initform nil)
  13    (instance
  14     :accessor meta-model.instance
  15     :initarg :instance
  16     :initform nil)
  17    (base-type
  18     :accessor meta-model.base-type
  19     :initform 'clsql)))
  20
  21 (defmethod meta-model.metadata ((self (eql nil)))
  22   nil)
  23
  24 (defun gen-supers (supers)
  25   (let (subclassp)
  26     (dolist (x supers)
  27       (when (member x (list-meta-models))
  28         (setf subclassp t)))
  29     (if subclassp
  30         supers
  31         (cons 'meta-model-class supers))))
  32
  33 (defmethod %def-meta-model ((base-type t) name supers slots &rest options)
  34   `(defclass ,name ,(gen-supers supers)
  35      ()
  36      (:default-initargs :metadata ',slots)))
  37
  38
  39 (defmacro def-meta-model (name supers slots &rest options)
  40   `(progn
  41      (when (not (member (quote ,name) *meta-models*))
  42        (setf *meta-models* (cons (quote ,name) *meta-models*)))
  43
  44      (let ((class ,(%def-meta-model (cadr (or (assoc :base-type options) '(t t))) name supers slots options)))
  45        class)))
  46
  47 (defgeneric def-base-class-expander (model base-type name args))
  48
  49
  50 (defmacro def-base-class (name (model) &rest args)
  51   (let ((i (make-instance model)))
  52     `(progn
  53        ,(def-base-class-expander i :clsql name args)
  54        (defmethod meta-model.metadata ((m ,name))
  55          ',(meta-model.metadata i)))))
  56
  57
  58 (defmethod base-class-name ((model t))
  59   (class-name (class-of (meta-model.instance model))))
  60
  61
  62
  63 (defmethod view-class-metadata ((model t))
  64   (meta-model.metadata model))
  65
  66 (defun list-item-helper (type view &key (ret-fun #'car))
  67   "A helper function for the LIST-* methods"
  68    (remove nil
  69            (mapcar #'(lambda (slot)
  70                           (let ((ret-val (funcall ret-fun slot))
  71                                 (kind (getf (cdr slot) :db-kind)))
  72                             (when (eql kind type)
  73                               ret-val )))
  74                    (view-class-metadata view))))
  75
  76 (defmethod list-join-attributes ((view t))
  77   "Returns all slots as an alist of (SLOT-NAME JOIN-ATTRIBUTES) where J-A is the contents of the :JOIN-CLASS portion of a slot definition"
  78   (remove nil (mapcar #'(lambda (def)(cons (car def) (getf (cdr def) :db-info ))) (view-class-metadata view))))
  79
  80 (defun list-relations-helper (view predicate-method &key (test-key :home-key) (return-key :join-class) (return-full nil))
  81   "A helper function for the listing join, relations and the like"
  82   (remove nil (mapcar #'(lambda (x)
  83               (when (funcall predicate-method view (getf (cdr x) test-key ))
  84                 (if return-full
  85                     x
  86                 (getf (cdr x) return-key ))))
  87           (list-join-attributes view))))
  88
  89 (defmethod list-slots ((view t))
  90   "list the non-joined slots of VIEW-CLASS"
  91   (remove-if #'(lambda (x) (find x (list-joins view)))
  92              (append (list-item-helper :key view)
  93                      (list-item-helper nil view)
  94                      (list-item-helper :base view))))
  95
  96 (defmethod list-slot-types ((view t))
  97   "Returns an alist of (slot-name slot-type) where SLOT-TYPE is the CLSQL type"
  98   (labels  ((rfun (slot)
  99               (cons (car slot)
 100                     (list (getf (cdr slot):type))))
 101             (lister (type)
 102               (list-item-helper
 103                type view
 104                :ret-fun #'rfun)))
 105     (append (lister :key) (lister :base))))
 106
 107 (defmethod slot-type ((view t) slot)
 108   "returns the CLSQL type of SLOT"
 109   (second (assoc slot (list-slot-types view))))
 110
 111 (defmethod list-joins ((view t))
 112   "lists slots that represent joins"
 113   (list-item-helper :join view))
 114
 115 (defmethod list-keys ((view t))
 116   "lists slots marked as :key"
 117   (list-item-helper :key view))
 118
 119 (defmethod primary-key-p ((view t) slot)
 120   "returns slot if it is primary key (NOTE: Currently this returns T if the slot appears in LIST_KEYS and does not take into account the :primary-key option. b0rked, to be sure"
 121   (find slot (list-keys view)))
 122
 123 (defmethod list-foreign-keys ((view t))
 124   "returns a list of FOREIGN-KEYS"
 125   (flet ((my-primary-key-p (slot)
 126            (primary-key-p view slot)))
 127     (remove nil (remove-if #'my-primary-key-p
 128                (mapcar #'(lambda (def)
 129                            (getf (cdr def) :home-key))
 130                        (list-join-attributes view))))))
 131
 132 (defmethod foreign-key-p ((view t) slot)
 133   "returns SLOT if it's a foreign key, nil otherwise"
 134   (find slot (list-foreign-keys view)))
 135
 136
 137
 138 (defmethod list-has-a ((view t))
 139   "returns a list of view-classes that are in a 1:1 relationship with VIEW"
 140   (list-relations-helper view #'foreign-key-p))
 141
 142 (defmethod list-has-many ((view t))
 143   "returns a list of view-classes that are in a 1:Many relationship with VIEW"
 144   (mapcar #'car
 145           (remove-if #'(lambda (x) (getf (cdr x) :target-slot))
 146                      (list-relations-helper
 147                       view
 148                       #'primary-key-p :return-full t))))
 149
 150 (defmethod list-many-to-many ((view t))
 151   "returns a list of view-classes that are in a Many:Many relationship with VIEW"
 152   (mapcar #'car (list-relations-helper
 153                  view
 154                  #'(lambda (c a)
 155                      (declare (ignore c))a)
 156                  :test-key :target-slot
 157                  :return-full t)))
 158
 159 (defmethod explode-foreign-key ((model clsql:standard-db-object) slot)
 160   "returns the clsql view-class joined on SLOT"
 161   (dolist (s (list-join-attributes model))
 162     (when (equal (getf (cdr s) :home-key) slot)
 163       (let ((val (slot-value model (car s))))
 164       (return-from explode-foreign-key
 165         (values (if val val (make-instance (getf (cdr s) :join-class))) (getf (cdr s) :foreign-key)))))))
 166
 167 (defun find-join-helper (foreign-key)
 168   (lambda (class slot)
 169     (declare (ignore class))
 170     (when (equal slot foreign-key) t)))
 171
 172 (defmethod find-join-class ((view t) foreign-key)
 173   "Returns the VIEW-CLASS that is joined to VIEW via FOREGN-KEY"
 174   (car (list-relations-helper view (find-join-helper foreign-key) )))
 175
 176 (defmethod find-join-key ((view t) foreign-key)
 177   "returns the SLOT in the foreign VIEW-CLASS that joins with FOREIGN-KEY"
 178   (car (list-relations-helper view (find-join-helper foreign-key) :return-key :foreign-key)))
 179
 180
 181