+++ /dev/null
-(in-package :meta-model)
-
-(defvar *meta-models* (make-hash-table))
-
-(defclass meta-model-class ()
- ((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)
- (instance
- :accessor meta-model.instance
- :initarg :instance
- :initform nil)
- (base-type
- :accessor meta-model.base-type
- :initarg :base-type
- :initform :clsql)))
-
-(defmethod meta-model.metadata ((self (eql nil)))
- nil)
-
-(defmethod meta-model.metadata ((self symbol))
- (meta-model.metadata (gethash self *meta-models*)))
-
-(defmethod meta-model.metadata ((self standard-object))
- (meta-model.metadata (class-name (class-of self))))
-
-(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))
-
-(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))
- "A helper function for the LIST-* methods"
- (remove nil
- (mapcar #'(lambda (slot)
- (let ((ret-val (funcall ret-fun slot))
- (kind (getf (cdr slot) :db-kind)))
- (when (eql kind type)
- ret-val )))
- (view-class-metadata view))))
-
-(defmethod list-join-attributes ((view t))
- "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"
- (remove nil (mapcar #'(lambda (def)(cons (car def) (getf (cdr def) :db-info ))) (view-class-metadata view))))
-
-(defun list-relations-helper (view predicate-method &key (test-key :home-key) (return-key :join-class) (return-full nil))
- "A helper function for the listing join, relations and the like"
- (remove nil (mapcar #'(lambda (x)
- (when (funcall predicate-method view (getf (cdr x) test-key ))
- (if return-full
- x
- (getf (cdr x) return-key ))))
- (list-join-attributes view))))
-
-(defmethod list-slots ((view t))
- "list the non-joined slots of VIEW-CLASS"
- (remove-if #'(lambda (x) (find x (list-joins view)))
- (append (list-item-helper :key view)
- (list-item-helper nil view)
- (list-item-helper :base view))))
-
-(defmethod list-slot-types ((view t))
- "Returns an alist of (slot-name slot-type) where SLOT-TYPE is the CLSQL type"
- (labels ((rfun (slot)
- (cons (car slot)
- (list (getf (cdr slot):type))))
- (lister (type)
- (list-item-helper
- type view
- :ret-fun #'rfun)))
- (append (lister :key) (lister :base) (lister nil))))
-
-(defmethod slot-type ((view t) slot)
- "returns the CLSQL type of SLOT"
- (second (assoc slot (list-slot-types view))))
-
-(defmethod list-joins ((view t))
- "lists slots that represent joins"
- (list-item-helper :join view))
-
-(defmethod list-keys ((view t))
- "lists slots marked as :key"
- (list-item-helper :key view))
-
-(defmethod primary-key-p ((view t) slot)
- "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"
- (find slot (list-keys view)))
-
-(defmethod list-foreign-keys ((view t))
- "returns a list of FOREIGN-KEYS"
- (flet ((my-primary-key-p (slot)
- (primary-key-p view slot)))
- (remove nil (remove-if #'my-primary-key-p
- (mapcar #'(lambda (def)
- (getf (cdr def) :home-key))
- (list-join-attributes view))))))
-
-(defmethod foreign-key-p ((view t) slot)
- "returns SLOT if it's a foreign key, nil otherwise"
- (find slot (list-foreign-keys view)))
-
-
-
-(defmethod list-has-a ((view t))
- "returns a list of view-classes that are in a 1:1 relationship with VIEW"
- (list-relations-helper view #'foreign-key-p))
-
-(defmethod list-has-many ((view t))
- "returns a list of view-classes that are in a 1:Many relationship with VIEW"
- (mapcar #'car
- (remove-if #'(lambda (x) (getf (cdr x) :target-slot))
- (list-relations-helper
- view
- #'primary-key-p :return-full t))))
-
-(defmethod list-many-to-many ((view t))
- "returns a list of view-classes that are in a Many:Many relationship with VIEW"
- (mapcar #'car (list-relations-helper
- view
- #'(lambda (c a)
- (declare (ignore c))a)
- :test-key :target-slot
- :return-full t)))
-
-(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)
- (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)
- (declare (ignore class))
- (when (equal slot foreign-key) t)))
-
-(defmethod find-join-class ((view t) foreign-key)
- "Returns the VIEW-CLASS that is joined to VIEW via FOREGN-KEY"
- (car (list-relations-helper view (find-join-helper foreign-key) )))
-
-(defmethod find-join-key ((view t) foreign-key)
- "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
HCoop / clinton / lisp-on-lines.git / blobdiff