Effective slots

.gitignore

@@ -9,3 +9,4 @@
 
 t/test.db
 .qlot/
+.emacs*

qlfile

@@ -3,3 +3,5 @@ ql cl-mysql :upstream
 ql dissect :upstream
 ql sxql :upstream
 ql rove :upstream
+github sharplispers/log4cl
+github 40ants/log4sly

qlfile.lock

@@ -27,3 +27,11 @@
   :initargs nil
   :version "ql-upstream-cacea7331c10fe9d8398d104b2dfd579bf7ea353"
   :remote-url "https://github.com/fukamachi/rove.git"))
+("log4cl" .
+ (:class qlot/source/github:source-github
+  :initargs (:repos "sharplispers/log4cl" :ref nil :branch nil :tag nil)
+  :version "github-fe3da517147d023029782ced7cd989ba24f1e62d"))
+("log4sly" .
+ (:class qlot/source/github:source-github
+  :initargs (:repos "40ants/log4sly" :ref nil :branch nil :tag nil)
+  :version "github-b229658c7fa8a8ff62cddd832e812cda96b50df6"))

src/core/class/column.lisp

@@ -7,7 +7,10 @@
                 #:delete-from-plist
                 #:ensure-car)
   (:export #:table-column-class
+           #:col-type                     
+           #:column-standard-effective-slot-definitions
            #:table-column-type
+           #:%table-column-type
            #:table-column-not-null-p
            #:table-column-name
            #:primary-key-p
@@ -29,14 +32,24 @@
     (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)
    (references :type references
                :initarg :references
                :initform nil
-               :reader table-column-references)
+               :accessor table-column-references)
    (primary-key :type boolean
                 :initarg :primary-key
                 :initform nil
@@ -47,17 +60,28 @@
           :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
-     (parse-col-type (%table-column-type column)))))
+     (parse-col-type (if (slot-boundp column 'col-type)
+                         (%table-column-type column)
+                         NIL)))))
 
 (defgeneric table-column-not-null-p (column)
   (:method ((column table-column-class))
     (nth-value 1 (parse-col-type (%table-column-type column)))))
 
 (defgeneric table-column-name (column)
   (:method ((column table-column-class))
+    (unlispify (symbol-name-literally (c2mop:slot-definition-name column))))
+  (:method ((column column-standard-effective-slot-definitions))
     (unlispify (symbol-name-literally (c2mop:slot-definition-name column)))))
 
 (defmethod initialize-instance :around ((class table-column-class) &rest rest-initargs
@@ -69,14 +93,7 @@
     (push (intern (symbol-name name) :keyword)
           (getf rest-initargs :initargs)))
 
-  (let ((class (apply #'call-next-method class rest-initargs)))
-    (unless (slot-boundp class 'col-type)
-      (if (or (ghost-slot-p class)
-              (slot-value class 'references))
-          (setf (slot-value class 'col-type) nil)
-          (error 'col-type-required
-                 :slot class)))
-    class))
+  (apply #'call-next-method class rest-initargs))
 
 (defgeneric table-column-references-column (column))
 

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,37 @@
 (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))
+         (have-col-type-slot (remove-if-not
+                              (lambda (x) (slot-exists-p x 'mito.class.column:col-type))
+                              direct-slot-definitions))
+         (found-col-types (remove-if-not
+                           (lambda (x) (slot-boundp x 'mito.class.column:col-type))
+                           have-col-type-slot)))
+    ;;(break)
+    (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))
+      (when found-col-types
+        (setf (%table-column-type result)
+              (some #'%table-column-type found-col-types)))
+      (setf (table-column-references result)
+            (some #'table-column-references direct-slot-definitions))
+      (setf (primary-key-p result)
+            (some #'primary-key-p direct-slot-definitions))
+      result)))
+
 (defgeneric table-name (class)
   (:method ((class table-class))
     (if (slot-value class 'table-name)

src/core/dao/column.lisp

@@ -3,32 +3,63 @@
   (:use #:cl
         #:mito.util)
   (:import-from #:mito.class.column
+                #:column-standard-effective-slot-definitions
                 #:table-column-class
                 #:table-column-type)
   (:import-from #:local-time)
   (:import-from #:cl-ppcre)
   (:export #:dao-table-column-class
            #:dao-table-column-inflate
+           #:dao-table-column-standard-effective-slot-definitions
            #:dao-table-column-deflate
+           #:inflate
+           #:inflate-if-bound
+           #:deflate
+           #:deflate-if-bound
            #:inflate-for-col-type
            #:deflate-for-col-type))
 (in-package :mito.dao.column)
 
 (defparameter *conc-name* nil)
 
-(defclass dao-table-column-class (table-column-class)
+(defclass dao-table-column-slot-definitions ()
   ((inflate :type (or function null)
+            :accessor inflate
             :initarg :inflate)
    (deflate :type (or function null)
+            :accessor deflate
             :initarg :deflate)))
 
+(defgeneric inflate (obj))
+(defmethod inflate (ob) nil)
+(defgeneric inflate-if-bound (ob))
+(defmethod inflate-if-bound (obj) nil)
+(defmethod inflate-if-bound ((obj dao-table-column-slot-definitions))
+  (when (slot-boundp obj 'mito.dao.column:inflate)
+    (slot-value obj 'mito.dao.column:inflate)))
+(defgeneric deflate (obj))
+(defmethod deflate (ob) nil)
+(defgeneric deflate-if-bound (ob))
+(defmethod deflate-if-bound (obj) nil)
+(defmethod deflate-if-bound ((obj dao-table-column-slot-definitions))
+  (when (slot-boundp obj 'mito.dao.column:deflate)
+    (slot-value obj 'mito.dao.column:deflate)))
+
+(defclass dao-table-column-class (dao-table-column-slot-definitions table-column-class)
+  ())
+
+(defclass dao-table-column-standard-effective-slot-definitions
+    (dao-table-column-slot-definitions
+     column-standard-effective-slot-definitions)
+  ())
+
 (defmethod initialize-instance :around ((object dao-table-column-class) &rest rest-initargs
                                         &key name readers writers inflate deflate
                                         &allow-other-keys)
   (when *conc-name*
     (let ((accessor (intern
-                      (format nil "~:@(~A~A~)" *conc-name* name)
-                      *package*)))
+                     (format nil "~:@(~A~A~)" *conc-name* name)
+                     *package*)))
       (unless readers
         (pushnew accessor readers)
         (setf (getf rest-initargs :readers) readers))

src/core/dao/mixin.lisp

@@ -15,6 +15,7 @@
                 #:table-column-name
                 #:table-column-references-column)
   (:import-from #:mito.dao.column
+                #:dao-table-column-standard-effective-slot-definitions
                 #:dao-table-column-class
                 #:dao-table-column-inflate
                 #:*conc-name*)
@@ -46,6 +47,10 @@
 (defmethod c2mop:direct-slot-definition-class ((class dao-table-mixin) &key)
   'dao-table-column-class)
 
+(defmethod c2mop:effective-slot-definition-class ((class dao-table-mixin) &rest initargs)
+  (declare (ignorable initargs))
+  (find-class 'mito.dao.column:dao-table-column-standard-effective-slot-definitions))
+
 (defgeneric make-dao-instance (class &rest initargs)
   (:method ((class-name symbol) &rest initargs)
     (apply #'make-dao-instance

src/core/dao/table.lisp

@@ -14,7 +14,12 @@
                 #:table-primary-key
                 #:create-table-sxql)
   (:import-from #:mito.dao.column
+                #:inflate
+                #:inflate-if-bound
+                #:deflate-if-bound
+                #:deflate
                 #:dao-table-column-class
+                #:dao-table-column-standard-effective-slot-definitions
                 #:dao-table-column-inflate)
   (:import-from #:mito.dao.mixin
                 #:dao-table-mixin
@@ -36,6 +41,26 @@
 (defmethod c2mop:direct-slot-definition-class ((class dao-table-class) &key)
   'dao-table-column-class)
 
+(defmethod c2mop:effective-slot-definition-class ((class dao-table-class) &rest initargs)
+  (declare (ignorable initargs))
+  (find-class 'dao-table-column-standard-effective-slot-definitions))
+
+(defmethod c2mop:validate-superclass ((class dao-table-class) (super standard-class))
+  t)
+
+(defmethod c2mop:compute-effective-slot-definition
+    :around ((class dao-table-class) name direct-slot-definitions)
+  (declare (ignorable name))
+  (let ((result (call-next-method)))
+    (when result
+      ;; set here all the relevant slots.
+      ;; set here inflate and deflate from dao-table-column-standard-effective-slot-definitions
+      (setf (inflate result)
+            (some #'inflate-if-bound direct-slot-definitions))
+      (setf (deflate result)
+            (some #'deflate-if-bound direct-slot-definitions))
+      result)))
+
 (defun initargs-enables-auto-pk (initargs)
   (first (or (getf initargs :auto-pk) '(:serial))))
 

src/core/dao/view.lisp

@@ -5,6 +5,7 @@
                 #:table-class
                 #:table-name)
   (:import-from #:mito.dao.column
+                #:dao-table-column-standard-effective-slot-definitions
                 #:dao-table-column-class)
   (:import-from #:sxql)
   (:export #:dao-table-view
@@ -20,6 +21,10 @@
 (defmethod c2mop:direct-slot-definition-class ((class dao-table-view) &key)
   'dao-table-column-class)
 
+(defmethod c2mop:effective-slot-definition-class ((class dao-table-view) &rest initargs)
+  (declare (ignorable initargs))
+  (find-class 'mito.dao.column:dao-table-column-standard-effective-slot-definitions))
+
 (defstruct (create-view (:include sxql.sql-type:sql-statement (sxql.sql-type:name "CREATE VIEW"))
                         (:constructor make-create-view (view-name &key or-replace as)))
   view-name

t/class.lisp

@@ -260,7 +260,7 @@
 )")
   (is-table-class :mysql
                   (defclass tweet ()
-                    ((user-name :references (user name)))
+                    ((user-name :references (user name) :col-type (:or :null :text)))
                     (:metaclass table-class))
                   "CREATE TABLE tweet (
     user_name VARCHAR(64) NOT NULL