#.(progn (ql:quickload :closer-mop) nil)

(defpackage :fwoar.simple-clone
  (:use :cl )
  (:export #:cloneable-class
           #:make-from))
(in-package :fwoar.simple-clone)

(defclass cloneable-class (c2mop:standard-class)
  ((%parent :initform (make-hash-table :test 'eq :weakness :key)
            :reader parent)))

(defmethod c2mop:validate-superclass ((class cloneable-class) (superclass c2mop:standard-class))
  t)

(defmethod c2mop:slot-boundp-using-class ((class cloneable-class) instance slotd)
  (or (call-next-method)
      (alexandria:when-let ((next (gethash instance (parent class))))
        (slot-boundp next
                     (c2mop:slot-definition-name slotd)))))

(defmethod c2mop:slot-value-using-class ((class cloneable-class) instance slotd)
  (block nil
    (handler-bind ((unbound-slot
                     (lambda (c)
                       (declare (ignore c))
                       (alexandria:when-let* ((next (gethash instance (parent class)))
                                              (value (slot-value next
                                                                 (c2mop:slot-definition-name slotd))))
                         (return (setf (c2mop:slot-value-using-class class instance slotd)
                                       value))))))
      (call-next-method))))

(defun make-from (a &rest r &key &allow-other-keys)
  (let* ((the-class (class-of a))
         (result (apply #'make-instance the-class r)))
    (prog1 result
      (setf (gethash result (parent the-class)) a))))

(defun relate (base derive)
  (let ((dict (parent (class-of derive))))
    (setf (gethash derive dict)
          base)))

#+(or)
(progn
  (defclass base ()
    ((a :initarg :a :reader a)
     (b :initarg :b :reader b)
     (c :initarg :c :reader c)))

  (defclass test ()
    ((a :initarg :a :reader a)
     (b :initarg :b :reader b)
     (c :initarg :c :reader c))
    (:metaclass cloneable-class))

  (defmethod print-object ((o test) s)
    (with-accessors ((a a) (b b) (c c)) o
      (print-unreadable-object (o s :type t :identity t)
        (handler-bind ((unbound-slot (lambda (c) (use-value :unbound c))))
          (format s "(a: ~s b: ~s c: ~s)"
                  (with-simple-restart (use-value "skip slot ~s" 'a)
                    a)
                  (with-simple-restart (use-value "skip slot ~s" 'b)
                    b)
                  (with-simple-restart (use-value "skip slot ~s" 'c)
                    c)))))))