Implementation of effective standard slots for the mito metaclass

fukamachi · Oct 31, 2024 · 58e8d9a · 58e8d9a
1 parent 90e638b
commit 58e8d9a
Show file tree

Hide file tree

Showing 2 changed files with 45 additions and 1 deletion.
diff --git a/src/core/class/column.lisp b/src/core/class/column.lisp
@@ -7,7 +7,9 @@
                 #:delete-from-plist
                 #:ensure-car)
   (:export #:table-column-class
+           #:column-standard-effective-slot-definitions
            #:table-column-type
+           #:%table-column-type
            #:table-column-not-null-p
            #:table-column-name
            #:primary-key-p
@@ -29,7 +31,17 @@
     (otherwise
      (values col-type t))))
 
-(defclass table-column-class (c2mop:standard-direct-slot-definition)
+
+(defgeneric %table-column-type (obj))
+(defmethod %table-column-type (ob) nil)
+(defgeneric table-column-references (obj))
+(defmethod table-column-references (ob) nil)
+(defgeneric primary-key-p (obj))
+(defmethod primary-key-p (ob) nil)
+(defgeneric ghost-slot-p (obj))
+(defmethod ghost-slot-p (ob) nil)
+
+(defclass column-slot-definitions ()
   ((col-type :type (or symbol cons null)
              :initarg :col-type
              :accessor %table-column-type)
@@ -47,6 +59,13 @@
           :accessor ghost-slot-p
           :documentation "Option to specify slots as ghost slots. Ghost slots do not depend on a database.")))
 
+(defclass table-column-class (column-slot-definitions c2mop:standard-direct-slot-definition)
+  ())
+
+(defclass column-standard-effective-slot-definitions (column-slot-definitions
+                                                      c2mop:standard-effective-slot-definition)
+  ())
+
 (defgeneric table-column-type (column)
   (:method ((column table-column-class))
     (values

diff --git a/src/core/class/table.lisp b/src/core/class/table.lisp
@@ -5,7 +5,10 @@
   (:import-from #:mito.class.column
                 #:parse-col-type
                 #:table-column-class
+                #:table-column-references
+                #:column-standard-effective-slot-definitions
                 #:table-column-type
+                #:%table-column-type
                 #:table-column-name
                 #:primary-key-p
                 #:ghost-slot-p)
@@ -140,9 +143,31 @@
 (defmethod c2mop:direct-slot-definition-class ((class table-class) &key &allow-other-keys)
   'table-column-class)
 
+(defmethod c2mop:effective-slot-definition-class ((class table-class) &rest initargs)
+  (declare (ignorable initargs))
+  (find-class 'column-standard-effective-slot-definitions))
+
 (defmethod c2mop:validate-superclass ((class table-class) (super standard-class))
   t)
 
+(defmethod c2mop:compute-effective-slot-definition
+    :around ((class table-class) name direct-slot-definitions)
+  (declare (ignorable name))
+  (let ((result (call-next-method)))
+    (when result
+      ;; set here all the relevant slots. See column-standard-effective-slot-definitions
+      (setf (ghost-slot-p result)
+            (some #'ghost-slot-p direct-slot-definitions))
+      (setf (%table-column-type result)
+            (some #'%table-column-type direct-slot-definitions))
+      ;; table-column-references is a reader, not an accessor. Unclear if this should be set.
+      ;; (setf (table-column-references result)
+      ;;       (some #'table-column-references direct-slot-definitions))
+      (setf (primary-key-p result)
+            (some #'primary-key-p direct-slot-definitions))
+      (setf )
+      result)))
+
 (defgeneric table-name (class)
   (:method ((class table-class))
     (if (slot-value class 'table-name)