Did some work on searching, changed object presentation to specialise on each row...
[clinton/lisp-on-lines.git] / src / meta-model.lisp
CommitLineData
579597e3 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
9d6c69fb
DC
19 :initarg :base-type
20 :initform :clsql)))
579597e3 21
22(defmethod meta-model.metadata ((self (eql nil)))
23 nil)
24
bf5ae490
DC
25(defmethod meta-model.metadata ((self symbol))
26 (meta-model.metadata (make-instance self)))
27
579597e3 28(defun gen-supers (supers)
29 (let (subclassp)
30 (dolist (x supers)
31 (when (member x (list-meta-models))
32 (setf subclassp t)))
33 (if subclassp
34 supers
35 (cons 'meta-model-class supers))))
36
37(defmethod %def-meta-model ((base-type t) name supers slots &rest options)
1da9fd46
DC
38 `(eval-when (:compile-toplevel :load-toplevel :execute)
39 (defclass ,name ,(gen-supers supers)
40 ()
41 (:default-initargs :metadata ',slots :base-type ,base-type))))
579597e3 42
43
44(defmacro def-meta-model (name supers slots &rest options)
1da9fd46 45 `(eval-when (:compile-toplevel :load-toplevel :execute)
579597e3 46 (when (not (member (quote ,name) *meta-models*))
47 (setf *meta-models* (cons (quote ,name) *meta-models*)))
48
49 (let ((class ,(%def-meta-model (cadr (or (assoc :base-type options) '(t t))) name supers slots options)))
50 class)))
51
9d6c69fb 52(defgeneric def-base-type-class-expander (base-type model name args))
579597e3 53
9d6c69fb
DC
54(defmethod def-base-class-expander ((model t) name args)
55 (def-base-type-class-expander (meta-model.base-type model) model name args))
579597e3 56
579597e3 57(defmethod base-class-name ((model t))
58 (class-name (class-of (meta-model.instance model))))
579597e3 59
60(defmethod view-class-metadata ((model t))
835ac88d
DC
61 "
62This is what meta-model.metadata used to be called,
63most of the below functions expect this method to exist"
579597e3 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)))
4e7631c9 105 (append (lister :key) (lister :base) (lister nil))))
579597e3 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)
4eabb213 163 (let ((val (slot-value model (car s))))
164 (return-from explode-foreign-key
233380f7 165 (values (if val val (make-instance (getf (cdr s) :join-class)))
166 (getf (cdr s) :foreign-key)))))))
579597e3 167
168(defun find-join-helper (foreign-key)
169 (lambda (class slot)
170 (declare (ignore class))
171 (when (equal slot foreign-key) t)))
172
173(defmethod find-join-class ((view t) foreign-key)
174 "Returns the VIEW-CLASS that is joined to VIEW via FOREGN-KEY"
175 (car (list-relations-helper view (find-join-helper foreign-key) )))
176
177(defmethod find-join-key ((view t) foreign-key)
178 "returns the SLOT in the foreign VIEW-CLASS that joins with FOREIGN-KEY"
179 (car (list-relations-helper view (find-join-helper foreign-key) :return-key :foreign-key)))
180
a6644385 181(defmethod explode-has-many ((view t) join-slot)
182 "returns the class of the join as the primary value, the second and third value is the home key and the foreign key"
183 (let ((att (assoc join-slot (list-join-attributes view))))
184 (values (getf (cdr att) :join-class)
185 (getf (cdr att) :home-key)
186 (getf (cdr att) :foreign-key))))
187
9d6c69fb
DC
188(defgeneric expr-= (instance slot-name value)
189 (:documentation "Create search expression for appropriate backend."))
a6644385 190
9d6c69fb
DC
191(defgeneric expr-> (instance slot-name value)
192 (:documentation "Create search expression for appropriate backend."))
579597e3 193
9d6c69fb
DC
194(defgeneric expr-< (instance slot-name value)
195 (:documentation "Create search expression for appropriate backend."))
579597e3 196
9d6c69fb
DC
197(defgeneric expr-ends-with (instance slot-name value)
198 (:documentation "Create search expression for appropriate backend."))
199
200(defgeneric expr-starts-with (instance slot-name value)
201 (:documentation "Create search expression for appropriate backend."))
202
203(defgeneric expr-contains (instance slot-name value)
204 (:documentation "Create search expression for appropriate backend."))
205
206(defgeneric expr-and (instance &rest args)
207 (:documentation "Create search expression for appropriate backend."))
208
209(defgeneric expr-or (instance &rest args)
210 (:documentation "Create search expression for appropriate backend."))
211
212(defgeneric expr-not (instance &rest args)
213 (:documentation "Create search expression for appropriate backend."))
214
215(defgeneric select-instances (instance &rest args)
216 (:documentation "Select instances in backend dependent way"))
217
f1ce8b6e
DC
218(defgeneric prepare-slot-name-for-select (instance slot-name)
219 (:method (i s) s))
220
9d6c69fb
DC
221(defmacro def-compare-expr (instance-type name expr &key value-format)
222 `(defmethod ,name ((instance ,instance-type) slot-name value)
223 (declare (ignore instance))
f1ce8b6e 224 (,expr (prepare-slot-name-for-select instance slot-name) ,(typecase value-format
9d6c69fb
DC
225 (null 'value)
226 (string `(format nil ,value-format value))
227 (t `(,value-format value))))))
228
f1ce8b6e 229
9d6c69fb
DC
230(defmacro def-logical-expr (instance-type name expr)
231 `(defmethod ,name ((instance ,instance-type) &rest args)
232 (declare (ignore instance))
233 (apply ,expr args)))