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