;;; Metaobject Protocol

(require 'closer-mop)
(require 'alexandria)

(defclass attributes-class (standard-class) ())

;; The following is from
;; https://stackoverflow.com/questions/21986977/additional-properties-to-slot-definition
;; (I was getting the same error)
;; I added the accessors, too.

(defclass attributes-direct-slot-definition (c2mop:standard-direct-slot-definition)
  ((attributes :initform nil :initarg :attributes :accessor attributes)))

(defclass attributes-effective-slot-definition (c2mop:standard-effective-slot-definition)
  ((attributes :initform nil :initarg :attributes :accessor attributes)))

(defmethod c2mop:direct-slot-definition-class ((class attributes-class) &rest initargs)
  (find-class 'attributes-direct-slot-definition))

(defmethod c2mop:effective-slot-definition-class ((class attributes-class) &rest initargs)
  (find-class 'attributes-effective-slot-definition))

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

;; The rest is from the Art of the Metaobject Protocol p. 87

(defmethod c2mop:compute-effective-slot-definition ((class attributes-class)
                                                    name ;; the book doesn't have this parameter
                                                    direct-slots)
  (let ((normal-slot (call-next-method)))
    (setf (attributes normal-slot)
          (remove-duplicates
           (alexandria:mappend #'attributes direct-slots)))
    normal-slot))

(defmethod c2mop:compute-slots ((class attributes-class))
  (let* ((normal-slots (call-next-method))
         (alist (mapcar (lambda (slot)
                          (cons (c2mop:slot-definition-name slot)
                                (mapcar (lambda (attr) (cons attr nil))
                                        (attributes slot))))
                        normal-slots)))
    (cons (make-instance 'c2mop:effective-slot-definition
                         :name 'all-attributes
                         :initform `',alist
                         :initfunction (lambda () alist))
          normal-slots)))

(defun slot-attribute-bucket (instance slot-name attribute)
  (let* ((all-buckets (slot-value instance 'all-attributes))
         (slot-bucket (assoc slot-name all-buckets)))
    (unless slot-bucket
      (error "The slot named ~S of ~S has no attributes."
             slot-name instance))
    (let ((attr-bucket (assoc attribute (cdr slot-bucket))))
      (unless attr-bucket
        (error "The slot named ~S of ~S has no attribute named ~S."
               slot-name instance attribute))
      attr-bucket)))

(defun slot-attribute (instance slot-name attribute)
  (cdr (slot-attribute-bucket instance slot-name attribute)))

(defun (setf slot-attribute) (new-value instance slot-name attribute)
  (setf (cdr (slot-attribute-bucket instance slot-name attribute))
        new-value))

;; test code

(defclass credit-rating ()
  ((level :attributes (date-set time-set)))
  (:metaclass attributes-class))

(setq cr (make-instance 'credit-rating))
;; =>
;; There is no applicable method for the generic function
;;   #<STANDARD-GENERIC-FUNCTION SB-MOP:SLOT-DEFINITION-ALLOCATION (3)>
;; when called with arguments
;;   (#<SB-MOP:EFFECTIVE-SLOT-DEFINITION COMMON-LISP-USER::ALL-ATTRIBUTES>).

;; == Fix attempt, copied from std-class.lisp ==
(defmethod c2mop:slot-definition-allocation ((slotd attributes-effective-slot-definition))
  :instance)

(slot-attribute cr 'level 'date-set)
(setf (slot-attribute cr 'level 'date-set) "123/324/41")
(slot-attribute cr 'level 'date-set)