Search code examples
common-lispclosmop

Slot Definition Disappearing when using two metaclasses


I'm trying to define a new slot definition called :has-many and the same time use the definitions provided by mito's metaclass mito:dao-table-class. https://github.com/fukamachi/mito?tab=readme-ov-file#deftable-macro

For some reason, when I add the metaclass I created on a normal object, the slot definition for has-many shows up as expected:

(defclass sample-class ()
   ((hello :has-many T))
   (:metaclass oql-metaclass))

(inspect (closer-mop:class-direct-slots (find-class 'sample-class)))

Here's the slot definition code:

(defclass has-many-meta-class (closer-mop:standard-class) ())

(defclass has-many-standard-direct-slot-definition (c2mop:standard-direct-slot-definition)
  ((has-many :initform nil
             :initarg :has-many
             :accessor has-many-slot-value)))

(defclass has-many-standard-effective-slot-definition (closer-mop:standard-effective-slot-definition)
  ((has-many :initform nil
             :initarg :has-many
             :accessor has-many-slot-value)))

(closer-mop:defmethod direct-slot-definition-class ((class has-many-meta-class)
                                                    &rest initargs)
  (find-class 'has-many-standard-direct-slot-definition))

(closer-mop:defmethod effective-slot-definition-class ((class has-many-meta-class)
                                                       &rest initargs)
  (find-class 'has-many-standard-effective-slot-definition))

(closer-mop:defmethod validate-superclass ((class has-many-meta-class)
                                           (superclass closer-mop:standard-class))
  t)

;; (defclass oql-metaclass (mito:dao-table-class
;;                          has-many-meta-class)
;;   ())

(defclass oql-metaclass (has-many-meta-class mito:dao-table-class)
  ())

However, when doing:

(defclass new-model () 
  ((author :has-many T :col-type :null))
  (:metaclass oql-metaclass))

The class will either not compile if oql-metaclass has the inheritance to be has-many-meta-class first, saying that :col-type is causing a problem, or if using (the commented out) order of mito's metaclass first in the inheritance list, the code compiles, but upon evaluating the class slots :has-many is not there.

Why is this? How can I work with both of them?

Note I used these answers to get this far:


Solution

  • Thanks to @beach for the guidance to this answer.

    The problem is that direct-slot-definition-class is not specialized for oql-metaclass. What happens then is that since oql-metaclass inherits from two other classes, the CLOS will find the method that matches the most specialized super class of oql-metaclass. That is why changing the order of the super classes affects the condition raised by the compiler.

    The solution is then to further specialize the direct-slot-definition-class method for oql-metaclass to return the correct slot definitions we want. Then we realize that we need a new class for those definitions.

    (defclass oql-standard-direct-slot-definition 
       (mito.dao.column:dao-table-column-class 
        has-many-standard-direct-slot-definition)
      ())
    

    Notice that we are here extending mito.dao.column:dao-table-column-class which is not the same class as the metaclass used for mito classes. That is because this is the direct slot definition class. I had to check the source code for mito to find it.

    Here is the new specialized method for direct slot definitions:

    (defmethod closer-mop:direct-slot-definition-class ((class oql-metaclass)
                                                        &rest initargs)
      (find-class 'oql-standard-direct-slot-definition))
    

    And now we can test it with

    (defclass oql-class-2 ()
      ((a :ghost T :has-many T))
      (:metaclass oql-metaclass))
    
    (inspect (find-class 'oql-class-2))
    (inspect (closer-mop:class-direct-slots (find-class 'oql-class-2)))
    

    In the inspector you should be able to see:

    CL-USER> (closer-mop:class-direct-slots (find-class 'oql-class-2))
    (#<OQL-STANDARD-DIRECT-SLOT-DEFINITION COMMON-LISP-USER::A>)
    CL-USER> (inspect (closer-mop:class-direct-slots (find-class 'oql-class-2)))
    
    The object is a CONS.
    0. CAR: #<OQL-STANDARD-DIRECT-SLOT-DEFINITION COMMON-LISP-USER::A>
    1. CDR: NIL
    > 0
    
    The object is a STANDARD-OBJECT of type OQL-STANDARD-DIRECT-SLOT-DEFINITION.
    0. SOURCE: #S(SB-C:DEFINITION-SOURCE-LOCATION :NAMESTRING NIL :INDICES 0)
    1. NAME: A
    2. INITFORM: NIL
    3. INITFUNCTION: NIL
    4. INITARGS: (:A)
    5. %TYPE: T
    6. %DOCUMENTATION: NIL
    7. %CLASS: #<OQL-METACLASS COMMON-LISP-USER::OQL-CLASS-2>
    8. READERS: NIL
    9. WRITERS: NIL
    10. ALLOCATION: :INSTANCE
    11. ALLOCATION-CLASS: NIL
    12. HAS-MANY: T
    13. COL-TYPE: NIL
    14. REFERENCES: NIL
    15. PRIMARY-KEY: NIL
    16. GHOST: T
    17. INFLATE: #<unbound slot>
    18. DEFLATE: #<unbound slot>
    

    Which has both has-many and col-type.

    I will further suggest, which is what I'm doing, to have the metaclass be a subclass of the mito metaclass in case there are other consequences of using that metaclass.

    (defclass oql-metaclass (mito:dao-table-class)
      ())