(ql:quickload :closer-mop)

(defclass dep ()
  ((val :accessor val :initarg :val)))

(defclass mc (standard-class)
  ((x :accessor x)
   ;; We need to not only store the value, but also store what the user
   ;; originally gave, so we can recompute later if one of our superclasses
   ;; changes.
   ;;
   ;; This slot will be unbound if the user didn't give an (:x foo) option, or
   ;; bound to (foo) if they did.
   (given-x :initarg :x :accessor given-x)))

(defun mcp (object)
  (typep object 'mc))

(defmethod c2mop:validate-superclass ((a mc) (b standard-class)) t)

(defun dep= (d class)
  (and (typep d 'dep) ; need to filter out any other deps other code might have added
       (eql (val d) class)))

(defun ensure-dep (superclass class)
  (c2mop:map-dependents superclass
                        (lambda (d)
                          (when (dep= d class)
                            (return-from ensure-dep))))
  (c2mop:add-dependent superclass (make-instance 'dep :val class)))

(defun ensure-no-dep (superclass class)
  (c2mop:map-dependents superclass
                        (lambda (d)
                          (when (dep= d class)
                            (c2mop:remove-dependent superclass d)
                            (return-from ensure-no-dep)))))

(defun recompute (&key class superclasses slot given-slot value value? default)
  (format *debug-io* "~%Recomputing ~A of ~A." slot class)
  (setf superclasses (remove-if-not #'mcp superclasses))
  ;; We need to store whether the user gave an explicit value for later.
  (if value?
    (setf (slot-value class given-slot) value)
    (slot-makunbound class given-slot))
  ;; Set the actual value to the given value, or the superclass value, or the default.
  ;;
  ;; I THINK we only need to look at direct superclasses, not the entire class
  ;; precedence list, because while it's possible for an MC to inherit from
  ;; a standard-class, the reverse is not possible.  So the only way for an MC
  ;; to get into the precedence list is to be there directly or come through
  ;; another MC that IS direct (and which would come first in the full list
  ;; anyway).
  (setf (slot-value class slot)
        (cond
          (value? (first value))
          (superclasses (slot-value (first superclasses) slot))
          (t default))))


(defmethod initialize-instance :around ((class mc) &key
                                        (x nil x?)
                                        direct-superclasses &allow-other-keys)
  (recompute :class class
             :superclasses direct-superclasses
             :slot 'x
             :given-slot 'given-x
             :value x
             :value? x?
             :default :some-default)
  (call-next-method)
  ;; You might think we could get away with only having dependencies on
  ;; superclasses that happen to be our specific metaclass, instead of on ALL
  ;; direct superclasses.  Sadly this fails for forward-referenced classes, so
  ;; we need to add dependencies on all of them and filter out the non-MC
  ;; classes later.
  (dolist (superclass (c2mop:class-direct-superclasses class))
    (ensure-dep superclass class)))

(defmethod reinitialize-instance :around ((class mc) &key
                                          (x nil x?)
                                          (direct-superclasses nil direct-superclasses?)
                                          &allow-other-keys)
  ;; We have to recompute X /before/ we call-next-method because the
  ;; update-dependent calls happen as part of that next method.  If we wait
  ;; until after call-next-method to patch up X, then the dependent will still
  ;; see the old version when it's updated and won't get the new value until
  ;; a second round of initialization.
  (recompute :class class
             :superclasses (if direct-superclasses?
                             direct-superclasses
                             (c2mop:class-direct-superclasses class))
             :slot 'x
             :given-slot 'given-x
             :value x
             :value? x?
             :default :some-default)
  (let ((before (c2mop:class-direct-superclasses class)))
    (call-next-method)
    (let* ((after (c2mop:class-direct-superclasses class))
           (removed (set-difference before after))
           (added (set-difference after before)))
      (dolist (superclass removed)
        (ensure-no-dep superclass class))
      (dolist (superclass added)
        (ensure-dep superclass class)))))

(defmethod c2mop:update-dependent (obj (dep dep) &rest initargs)
  (declare (ignore initargs))
  (when (typep obj 'mc) ; We can ignore changes in non-MC superclasses here.
    (let ((class (val dep)))
      (format *debug-io* "~%Updating ~A because ~A changed." class obj)
      ;; Need to call reinitialize-instance here (instead of just recomputing the
      ;; slots) because otherwise transitive dependencies won't get updated
      ;; properly.
      (apply #'reinitialize-instance class
             (if (slot-boundp class 'given-x)
               (list :x (slot-value class 'given-x))
               '())))))

;;;; ----------------------------------------------------------------------------

(defun p (class)
  (princ class)
  (let ((class (find-class class)))
    (print (list 'x (s class 'x)))
    (print (list 'given-x (s class 'given-x))))
  (values))


(defclass foo () ()) ; standard-class

(defclass a ()
  ()
  (:metaclass mc))

;; A should have the default.
(p 'a)
; A
; (X :SOME-DEFAULT)
; (GIVEN-X :UNBOUND)

(defclass b ()
  ()
  (:metaclass mc)
  (:x 1))

;; B has an explicit value.
(p 'b)
; B
; (X 1)
; (GIVEN-X (1))

(defclass c (foo a) ; standard class shouldn't mess with anything
  ()
  (:metaclass mc))

;; C inherits A's value.
(p 'c)
; C
; (X :SOME-DEFAULT)
; (GIVEN-X :UNBOUND)

(defclass d (c b)
  ()
  (:metaclass mc))

;; D inherit's C's value.
(p 'd)
; D
; (X :SOME-DEFAULT)
; (GIVEN-X :UNBOUND)

;; Now we redefine A to give it a value.
(defclass a ()
  ()
  (:metaclass mc)
  (:x 1234))

;; A gets the new value.
(p 'a)
; A
; (X 1234)
; (GIVEN-X (1234))

;; C picks up the new value.
(p 'c)
; C
; (X 1234)
; (GIVEN-X :UNBOUND)

;; And D picks up the new value transitively from C.
(p 'd)
; D
; (X 1234)
; (GIVEN-X :UNBOUND)

;; But we can cut that off by giving D a new explicit value:
(defclass d (c b)
  ()
  (:metaclass mc)
  (:x 0))

(defclass a ()
  ()
  (:metaclass mc)
  (:x 5678))

;; A and C get the new A value, but D doesn't.
(p 'a)
; A
; (X 5678)
; (GIVEN-X (5678))

(p 'c)
; C
; (X 5678)
; (GIVEN-X :UNBOUND)

(p 'd)
; D
; (X 0)
; (GIVEN-X (0))

;; Unless we wipe out D's explicit value:
(defclass d (c b)
  ()
  (:metaclass mc))

;; Now it's back to inheriting.
(p 'd)
; D
; (X 5678)
; (GIVEN-X :UNBOUND)


;; And god help us, forward-referenced classes work too.  Here wow is not yet
;; defined, so meow takes the default value.
(defclass meow (wow)
  ()
  (:metaclass mc))

(p 'meow)
; MEOW
; (X :SOME-DEFAULT)
; (GIVEN-X :UNBOUND)

;; When we get around to defining wow as a MC, meow will be updated too.
(defclass wow ()
  ()
  (:metaclass mc)
  (:x 2))

(p 'wow)
; WOW
; (X 2)
; (GIVEN-X (2))

(p 'meow)
; MEOW
; (X 2)
; (GIVEN-X :UNBOUND)