Major refactoring of meta-model code + added dependancy on cl-pg-introspect + patches
[clinton/lisp-on-lines.git] / src / meta-model.lisp
1 (in-package :meta-model)
2
3 (defvar *meta-models* (make-hash-table))
4
5 (defclass meta-model-class ()
6 ((name
7 :accessor meta-model.name
8 :initarg :name
9 :initform nil)
10 (slots
11 :accessor meta-model.slots
12 :initarg :slots
13 :initform nil)
14 (superclasses
15 :accessor meta-model.superclasses
16 :initarg :superclasses
17 :initform nil)
18 (options
19 :accessor meta-model.options
20 :initarg :options
21 :initform nil)
22 (metadata
23 :accessor meta-model.metadata
24 :initarg :metadata
25 :initform nil)
26 (instance
27 :accessor meta-model.instance
28 :initarg :instance
29 :initform nil)
30 (base-type
31 :accessor meta-model.base-type
32 :initarg :base-type
33 :initform :clsql)))
34
35 (defmethod meta-model.metadata ((self (eql nil)))
36 nil)
37
38 (defmethod meta-model.metadata ((self symbol))
39 (meta-model.metadata (gethash self *meta-models*)))
40
41 (defmethod meta-model.metadata ((self standard-object))
42 (meta-model.metadata (class-name (class-of self))))
43
44 (eval-when (:compile-toplevel :load-toplevel :execute)
45 (defmethod make-meta-model (name supers slots options)
46 (let ((m (make-instance 'meta-model-class
47 :name name
48 :superclasses supers
49 :slots slots
50 :options options
51 ;; TODO : the metadata should inherit any superclasses
52 :metadata slots)))
53 (setf (gethash name *meta-models*) m))))
54
55 (defmacro define-meta-model (name supers slots &rest options)
56 `(make-meta-model ',name ',supers ',slots ',options))
57
58 (defgeneric generate-base-class-definition (base-type model name args))
59
60 (defmethod generate-base-class-expander ((model t) name args)
61 (generate-base-class-definition (meta-model.base-type model) model name args))
62
63
64 (defmethod view-class-metadata ((model t))
65 "
66 This is what meta-model.metadata used to be called,
67 most of the below functions expect this method to exist"
68 (meta-model.metadata model))
69
70 (defun list-item-helper (type view &key (ret-fun #'car))
71 "A helper function for the LIST-* methods"
72 (remove nil
73 (mapcar #'(lambda (slot)
74 (let ((ret-val (funcall ret-fun slot))
75 (kind (getf (cdr slot) :db-kind)))
76 (when (eql kind type)
77 ret-val )))
78 (view-class-metadata view))))
79
80 (defmethod list-join-attributes ((view t))
81 "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"
82 (remove nil (mapcar #'(lambda (def)(cons (car def) (getf (cdr def) :db-info ))) (view-class-metadata view))))
83
84 (defun list-relations-helper (view predicate-method &key (test-key :home-key) (return-key :join-class) (return-full nil))
85 "A helper function for the listing join, relations and the like"
86 (remove nil (mapcar #'(lambda (x)
87 (when (funcall predicate-method view (getf (cdr x) test-key ))
88 (if return-full
89 x
90 (getf (cdr x) return-key ))))
91 (list-join-attributes view))))
92
93 (defmethod list-slots ((view t))
94 "list the non-joined slots of VIEW-CLASS"
95 (remove-if #'(lambda (x) (find x (list-joins view)))
96 (append (list-item-helper :key view)
97 (list-item-helper nil view)
98 (list-item-helper :base view))))
99
100 (defmethod list-slot-types ((view t))
101 "Returns an alist of (slot-name slot-type) where SLOT-TYPE is the CLSQL type"
102 (labels ((rfun (slot)
103 (cons (car slot)
104 (list (getf (cdr slot):type))))
105 (lister (type)
106 (list-item-helper
107 type view
108 :ret-fun #'rfun)))
109 (append (lister :key) (lister :base) (lister nil))))
110
111 (defmethod slot-type ((view t) slot)
112 "returns the CLSQL type of SLOT"
113 (second (assoc slot (list-slot-types view))))
114
115 (defmethod list-joins ((view t))
116 "lists slots that represent joins"
117 (list-item-helper :join view))
118
119 (defmethod list-keys ((view t))
120 "lists slots marked as :key"
121 (list-item-helper :key view))
122
123 (defmethod primary-key-p ((view t) slot)
124 "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"
125 (find slot (list-keys view)))
126
127 (defmethod list-foreign-keys ((view t))
128 "returns a list of FOREIGN-KEYS"
129 (flet ((my-primary-key-p (slot)
130 (primary-key-p view slot)))
131 (remove nil (remove-if #'my-primary-key-p
132 (mapcar #'(lambda (def)
133 (getf (cdr def) :home-key))
134 (list-join-attributes view))))))
135
136 (defmethod foreign-key-p ((view t) slot)
137 "returns SLOT if it's a foreign key, nil otherwise"
138 (find slot (list-foreign-keys view)))
139
140
141
142 (defmethod list-has-a ((view t))
143 "returns a list of view-classes that are in a 1:1 relationship with VIEW"
144 (list-relations-helper view #'foreign-key-p))
145
146 (defmethod list-has-many ((view t))
147 "returns a list of view-classes that are in a 1:Many relationship with VIEW"
148 (mapcar #'car
149 (remove-if #'(lambda (x) (getf (cdr x) :target-slot))
150 (list-relations-helper
151 view
152 #'primary-key-p :return-full t))))
153
154 (defmethod list-many-to-many ((view t))
155 "returns a list of view-classes that are in a Many:Many relationship with VIEW"
156 (mapcar #'car (list-relations-helper
157 view
158 #'(lambda (c a)
159 (declare (ignore c))a)
160 :test-key :target-slot
161 :return-full t)))
162
163 (defmethod explode-foreign-key ((model clsql:standard-db-object) slot &key (createp t))
164 "returns the clsql view-class joined on SLOT"
165 (dolist (s (list-join-attributes model))
166 (when (equal (getf (cdr s) :home-key) slot)
167 (let* ((fkey (getf (cdr s) :foreign-key))
168 (new (sync-instance (make-instance (getf (cdr s) :join-class))))
169 (val (or (slot-value model (car s))
170 (progn
171 (when createp
172 (setf
173 (slot-value model slot)
174 (slot-value new fkey))
175 (sync-instance model)
176 (slot-value model (car s)))))))
177
178 (return-from explode-foreign-key
179 (values val fkey))))))
180
181 (defun find-join-helper (foreign-key)
182 (lambda (class slot)
183 (declare (ignore class))
184 (when (equal slot foreign-key) t)))
185
186 (defmethod find-join-class ((view t) foreign-key)
187 "Returns the VIEW-CLASS that is joined to VIEW via FOREGN-KEY"
188 (car (list-relations-helper view (find-join-helper foreign-key) )))
189
190 (defmethod find-join-key ((view t) foreign-key)
191 "returns the SLOT in the foreign VIEW-CLASS that joins with FOREIGN-KEY"
192 (car (list-relations-helper view (find-join-helper foreign-key) :return-key :foreign-key)))
193
194 (defmethod explode-has-many ((view t) join-slot)
195 "returns the class of the join as the primary value, the second and third value is the home key and the foreign key"
196 (let ((att (assoc join-slot (list-join-attributes view))))
197 (values (getf (cdr att) :join-class)
198 (getf (cdr att) :home-key)
199 (getf (cdr att) :foreign-key))))
200
201 (defgeneric expr-= (instance slot-name value)
202 (:documentation "Create search expression for appropriate backend."))
203
204 (defgeneric expr-> (instance slot-name value)
205 (:documentation "Create search expression for appropriate backend."))
206
207 (defgeneric expr-< (instance slot-name value)
208 (:documentation "Create search expression for appropriate backend."))
209
210 (defgeneric expr-ends-with (instance slot-name value)
211 (:documentation "Create search expression for appropriate backend."))
212
213 (defgeneric expr-starts-with (instance slot-name value)
214 (:documentation "Create search expression for appropriate backend."))
215
216 (defgeneric expr-contains (instance slot-name value)
217 (:documentation "Create search expression for appropriate backend."))
218
219 (defgeneric expr-and (instance &rest args)
220 (:documentation "Create search expression for appropriate backend."))
221
222 (defgeneric expr-or (instance &rest args)
223 (:documentation "Create search expression for appropriate backend."))
224
225 (defgeneric expr-not (instance &rest args)
226 (:documentation "Create search expression for appropriate backend."))
227
228 (defgeneric select-instances (instance &rest args)
229 (:documentation "Select instances in backend dependent way"))
230
231 (defgeneric prepare-slot-name-for-select (instance slot-name)
232 (:method (i s) s))
233
234 (defmacro def-compare-expr (instance-type name expr &key value-format)
235 `(defmethod ,name ((instance ,instance-type) slot-name value)
236 (declare (ignore instance))
237 (,expr (prepare-slot-name-for-select instance slot-name) ,(typecase value-format
238 (null 'value)
239 (string `(format nil ,value-format value))
240 (t `(,value-format value))))))
241
242
243 (defmacro def-logical-expr (instance-type name expr)
244 `(defmethod ,name ((instance ,instance-type) &rest args)
245 (declare (ignore instance))
246 (apply ,expr args)))