X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/579597e310dfac262d629aade17f86c3d6b80da4..ec044146bf44d8b651c6da400bbb78694f5eb9a0:/src/meta-model.lisp diff --git a/src/meta-model.lisp b/src/meta-model.lisp index b0d1ff5..de7335e 100644 --- a/src/meta-model.lisp +++ b/src/meta-model.lisp @@ -1,12 +1,25 @@ (in-package :meta-model) -(defvar *meta-models* nil) - -(defun list-meta-models () - *meta-models*) +(defvar *meta-models* (make-hash-table)) (defclass meta-model-class () - ((metadata + ((name + :accessor meta-model.name + :initarg :name + :initform nil) + (slots + :accessor meta-model.slots + :initarg :slots + :initform nil) + (superclasses + :accessor meta-model.superclasses + :initarg :superclasses + :initform nil) + (options + :accessor meta-model.options + :initarg :options + :initform nil) + (metadata :accessor meta-model.metadata :initarg :metadata :initform nil) @@ -16,51 +29,42 @@ :initform nil) (base-type :accessor meta-model.base-type - :initform 'clsql))) + :initarg :base-type + :initform :clsql))) (defmethod meta-model.metadata ((self (eql nil))) nil) -(defun gen-supers (supers) - (let (subclassp) - (dolist (x supers) - (when (member x (list-meta-models)) - (setf subclassp t))) - (if subclassp - supers - (cons 'meta-model-class supers)))) - -(defmethod %def-meta-model ((base-type t) name supers slots &rest options) - `(defclass ,name ,(gen-supers supers) - () - (:default-initargs :metadata ',slots))) - - -(defmacro def-meta-model (name supers slots &rest options) - `(progn - (when (not (member (quote ,name) *meta-models*)) - (setf *meta-models* (cons (quote ,name) *meta-models*))) +(defmethod meta-model.metadata ((self symbol)) + (meta-model.metadata (gethash self *meta-models*))) - (let ((class ,(%def-meta-model (cadr (or (assoc :base-type options) '(t t))) name supers slots options))) - class))) +(defmethod meta-model.metadata ((self standard-object)) + (meta-model.metadata (class-name (class-of self)))) -(defgeneric def-base-class-expander (model base-type name args)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmethod make-meta-model (name supers slots options) + (let ((m (make-instance 'meta-model-class + :name name + :superclasses supers + :slots slots + :options options + ;; TODO : the metadata should inherit any superclasses + :metadata slots))) + (setf (gethash name *meta-models*) m)))) + +(defmacro define-meta-model (name supers slots &rest options) + `(make-meta-model ',name ',supers ',slots ',options)) +(defgeneric generate-base-class-definition (base-type model name args)) -(defmacro def-base-class (name (model) &rest args) - (let ((i (make-instance model))) - `(progn - ,(def-base-class-expander i :clsql name args) - (defmethod meta-model.metadata ((m ,name)) - ',(meta-model.metadata i))))) - - -(defmethod base-class-name ((model t)) - (class-name (class-of (meta-model.instance model)))) - +(defmethod generate-base-class-expander ((model t) name args) + (generate-base-class-definition (meta-model.base-type model) model name args)) (defmethod view-class-metadata ((model t)) + " +This is what meta-model.metadata used to be called, +most of the below functions expect this method to exist" (meta-model.metadata model)) (defun list-item-helper (type view &key (ret-fun #'car)) @@ -102,7 +106,7 @@ (list-item-helper type view :ret-fun #'rfun))) - (append (lister :key) (lister :base)))) + (append (lister :key) (lister :base) (lister nil)))) (defmethod slot-type ((view t) slot) "returns the CLSQL type of SLOT" @@ -156,11 +160,23 @@ :test-key :target-slot :return-full t))) -(defmethod explode-foreign-key ((model clsql:standard-db-object) slot) +(defmethod explode-foreign-key ((model clsql:standard-db-object) slot &key (createp t)) "returns the clsql view-class joined on SLOT" (dolist (s (list-join-attributes model)) (when (equal (getf (cdr s) :home-key) slot) - (return-from explode-foreign-key (slot-value model (car s)))))) + (let* ((fkey (getf (cdr s) :foreign-key)) + (new (sync-instance (make-instance (getf (cdr s) :join-class)))) + (val (or (slot-value model (car s)) + (progn + (when createp + (setf + (slot-value model slot) + (slot-value new fkey)) + (sync-instance model) + (slot-value model (car s))))))) + + (return-from explode-foreign-key + (values val fkey)))))) (defun find-join-helper (foreign-key) (lambda (class slot) @@ -175,5 +191,56 @@ "returns the SLOT in the foreign VIEW-CLASS that joins with FOREIGN-KEY" (car (list-relations-helper view (find-join-helper foreign-key) :return-key :foreign-key))) +(defmethod explode-has-many ((view t) join-slot) + "returns the class of the join as the primary value, the second and third value is the home key and the foreign key" + (let ((att (assoc join-slot (list-join-attributes view)))) + (values (getf (cdr att) :join-class) + (getf (cdr att) :home-key) + (getf (cdr att) :foreign-key)))) + +(defgeneric expr-= (instance slot-name value) + (:documentation "Create search expression for appropriate backend.")) + +(defgeneric expr-> (instance slot-name value) + (:documentation "Create search expression for appropriate backend.")) + +(defgeneric expr-< (instance slot-name value) + (:documentation "Create search expression for appropriate backend.")) + +(defgeneric expr-ends-with (instance slot-name value) + (:documentation "Create search expression for appropriate backend.")) + +(defgeneric expr-starts-with (instance slot-name value) + (:documentation "Create search expression for appropriate backend.")) + +(defgeneric expr-contains (instance slot-name value) + (:documentation "Create search expression for appropriate backend.")) + +(defgeneric expr-and (instance &rest args) + (:documentation "Create search expression for appropriate backend.")) + +(defgeneric expr-or (instance &rest args) + (:documentation "Create search expression for appropriate backend.")) + +(defgeneric expr-not (instance &rest args) + (:documentation "Create search expression for appropriate backend.")) + +(defgeneric select-instances (instance &rest args) + (:documentation "Select instances in backend dependent way")) + +(defgeneric prepare-slot-name-for-select (instance slot-name) + (:method (i s) s)) + +(defmacro def-compare-expr (instance-type name expr &key value-format) + `(defmethod ,name ((instance ,instance-type) slot-name value) + (declare (ignore instance)) + (,expr (prepare-slot-name-for-select instance slot-name) ,(typecase value-format + (null 'value) + (string `(format nil ,value-format value)) + (t `(,value-format value)))))) +(defmacro def-logical-expr (instance-type name expr) + `(defmethod ,name ((instance ,instance-type) &rest args) + (declare (ignore instance)) + (apply ,expr args))) \ No newline at end of file