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