cl-deck-builder2/src/models/registered-table-mixin.lisp

#|

src/models/registered-table-mixin.lisp

Model Object Class. Instead of writing new code every time for every
new Model (Model, View, Component), encapsulate the behavior here.

Now using mixins!

|#

(in-package #:cl-deck-builder2.models.registered-table)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Thanks mariari! https://lispcookbook.github.io/cl-cookbook/clos.html#metaclasses
(defclass model-registry ()
  ((registry :allocation :class
             :accessor model-registry
             :initform (make-hash-table))))

(defmethod registered-classes ((registry model-registry) &optional package)
  (if package
      (gethash (find-package package) (model-registry registry))
      ;; If no package was provided return a LIST of all packages tracked by the MODEL-REGISTRY.
      (apply #'concatenate 'list
             (alexandria:hash-table-values (model-registry registry)))))

(defparameter *registry* (make-instance 'model-registry)
  "Global model registry instance.")

(defun registry (&optional (registry *registry*))
  "Get the MODEL-REGISTRY associated with REGISTRY. Default is *REGISTRY*."
  registry)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Inherit from MITO:DAO-TABLE-CLASS because MITO:DAO-TABLE-MIXIN
;; doesn't have the additional PRIMARY-KEY or TIMESTAMP mechanisms or
;; anything.
(defclass registered-table-class (mito:dao-table-class) ())

(defmethod closer-mop:validate-superclass ((class registered-table-class)
                                           (superclass mito:dao-table-class))
  t)

(defmethod initialize-instance :after ((class registered-table-class) &rest initargs &key &allow-other-keys)
  (declare (ignore initargs))
  (pushnew (class-name class)
           (gethash (symbol-package (class-name class))
                    (model-registry (registry)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tables
(defmethod create-tables ((registry model-registry) &optional package) 
  "Create tables for CLASS-LIST by wrapping DBD:CREATE-TABLE."
  (apply #'create-table
         (registered-classes registry package)))

(defmethod drop-tables ((registry model-registry) &optional package)
  "Drop tables for CLASS-LIST by wrapping DB:DROP-TABLE."
  (apply #'drop-table 
         (registered-classes registry package)))

(defmethod recreate-tables ((registry model-registry) &optional package)
  (drop-tables registry package)
  (create-tables registry package))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod migration-expressions ((registry model-registry) &optional package)
  (with-connection (db)
    (with-transaction
      (mapcar #'mito:migration-expressions
              (registered-classes registry package)))))

(defmethod migrate-table ((registry model-registry) &optional package)
  (with-connection (db)
    (with-transaction
      (mapcar #'mito:migrate-table
              (registered-classes registry package)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ensure-tables-exist (&optional package)
  (create-tables (registry) package))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod export-registered-classes ((registry model-registry) &key package (stream *standard-output*))
  "Export REGISTERED-CLASSES for REGISTRY to STREAM, which by default, is *STANDARD-OUTPUT*."
  (with-connection (db)
    (with-transaction
      (format stream "~{~a~^;~%~};"
              (mapcar (lambda (class) (sxql:yield (car (mito:table-definition class))))
                      (registered-classes registry package))))))

(defun export-registered-classes-to-file (&key (output (relative-pathname "db/schema.sql")) package)
  (with-open-file (stream output
                          :direction :output
                          :if-exists :supersede
                          :if-does-not-exist :create)
    (export-registered-classes (registry) :package package :stream stream)
    (probe-file output)))