meta-helix-primary-key-example.lisp

;; https://github.com/eudoxia0/crane/issues/51#issuecomment-184441942
(defpackage #:meta-helix-example
  (:use #:cl #:c2mop)
  (:import-from #:alexandria
                #:if-let
                #:when-let)
  (:shadowing-import-from #:c2mop
                          #:standard-generic-function
                          #:defgeneric
                          #:defmethod)
  (:documentation "An example implementation of the Meta-Helix pattern[1] in
  the context of ORMs and primary-keys. For further context, see:
  https://github.com/eudoxia0/crane/issues/51

[1]: http://www2.parc.com/csl/groups/sda/publications/papers/Chiba-ISOTAS96/for-web.pdf"))

(in-package #:meta-helix-example)

(defgeneric primary-key (object)
  (:documentation "Return the 'primary key' slot. ID unless there is a slot
  with that name already."))

;; XXX: I'd like to say that we use weak-hastable to play nicer with the GC,
;; but in reality I ran into trouble with the canonical-slot-definition being
;; separte ofthe effectives-slot-definition itself when trying a eql on class
;; approach
(defparameter *primary-keys* (make-hash-table)
  "A mapping from the classes to its corresponding primary-key.")
(defmethod primary-key (object)
  (gethash object *primary-keys*))


;; Now we have to create a 'mirror' class whenever a class whose metaclass is table-class is defined

(defun canonicalize-slot-definition (slotdef)
  (list :name (slot-definition-name slotdef)
        :readers (slot-definition-readers slotdef)
        :writers (slot-definition-writers slotdef)
        :type (slot-definition-type slotdef)
        :allocation (slot-definition-allocation slotdef)
        :initargs (slot-definition-initargs slotdef)
        :initform (slot-definition-initform slotdef)
        :initfunction (slot-definition-initfunction slotdef)))

(defun slot-in-class-p (slot-name class)
  "If there is a slot with the name ID in class, return it."
  (declare (type symbol slot-name))
  (ensure-finalized class)
  (find slot-name (class-slots class) :key #'slot-definition-name))

(defun make-primary-key-slot-definition (maybe-slot)
  "Return an slot definition to be passed to ensure-class."
  (let ((slot-name (or (and maybe-slot (gensym "PRIMARY-KEY"))
                       'id)))
    (list :name slot-name
          :initform 'nil
          :initfunction (constantly nil)
          :initargs (list (intern (string slot-name) "KEYWORD"))
          :readers  (list slot-name)
          :writers  (list `(setf ,slot-name))
          ;; :documentation "A primary key for ..."
          )))

(defun make-shadow-class (class)
  ""
  ;; XXX: It is important not to copy the slots through inheritance
  (assert (classp class))
  (ensure-finalized class)
  
  (let* ((args nil)
         (shadow-class-name (gensym (format nil "SHADOW-OF-")))
         (maybe-id-slot (slot-in-class-p 'id class))
         (primary-key-slot (make-primary-key-slot-definition maybe-id-slot)))

    (when-let (direct-superclasses (class-direct-superclasses class))
      (push direct-superclasses args)
      (push :direct-superclasses args))

    (push (cons primary-key-slot
                (mapcar #'canonicalize-slot-definition (class-direct-slots class)))
          args)
    (push :direct-slots args)

    (push (class-of class) args)
    (push :metaclass args)

    
    (let ((shadow-class (apply #'ensure-class shadow-class-name args))
          (primary-key-name (getf primary-key-slot :name)))
      (setf (gethash class *primary-keys*)
            (or (slot-in-class-p primary-key-name class)
                (slot-in-class-p primary-key-name shadow-class)))
      shadow-class)))


;; Dribble

(defclass user ()
  ((email :initarg :email :accessor email)
   (username :initarg :username :accessor username)))

(defmethod print-object ((object user) stream)
  (print-unreadable-object (object stream :type t)
    (format stream "~A, Email: ~A" (username object) (email object))))

(make-shadow-class (find-class 'user))
(primary-key (find-class 'user))

(defclass post ()
  ((id :initarg :id :accessor id)
   (title :initarg :title :accessor title)))

(make-shadow-class (find-class 'post))
(primary-key (find-class 'post))