;; lib/common-lisp/clos.sx — CLOS: classes, instances, generic functions
;;
;; Class records: {:clos-type "class" :name "NAME" :slots {...} :parents [...] :methods [...]}
;; Instance:      {:clos-type "instance" :class "NAME" :slots {slot: val ...}}
;; Method:        {:qualifiers [...] :specializers [...] :fn (fn (args next-fn) ...)}
;;
;; SX primitive notes:
;;   dict->list: use (map (fn (k) (list k (get d k))) (keys d))
;;   dict-set (pure): use assoc
;;   fn?/callable?: use callable?

;; ── dict helpers ───────────────────────────────────────────────────────────

(define
  clos-dict->list
  (fn (d) (map (fn (k) (list k (get d k))) (keys d))))

;; ── class registry ─────────────────────────────────────────────────────────

(define
  clos-class-registry
  (dict
    "t"
    {:parents (list) :clos-type "class" :slots (dict) :methods (list) :name "t"}
    "null"
    {:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "null"}
    "integer"
    {:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "integer"}
    "float"
    {:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "float"}
    "string"
    {:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "string"}
    "symbol"
    {:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "symbol"}
    "cons"
    {:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "cons"}
    "list"
    {:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "list"}))

;; ── clos-generic-registry ─────────────────────────────────────────────────

(define clos-generic-registry (dict))

;; ── class-of ──────────────────────────────────────────────────────────────

(define
  clos-class-of
  (fn
    (x)
    (cond
      ((nil? x) "null")
      ((integer? x) "integer")
      ((float? x) "float")
      ((string? x) "string")
      ((symbol? x) "symbol")
      ((and (list? x) (> (len x) 0)) "cons")
      ((and (list? x) (= (len x) 0)) "null")
      ((and (dict? x) (= (get x "clos-type") "instance")) (get x "class"))
      (:else "t"))))

;; ── subclass-of? ──────────────────────────────────────────────────────────
;;
;; Captures clos-class-registry at define time to avoid free-variable issues.

(define
  clos-subclass-of?
  (let
    ((registry clos-class-registry))
    (fn
      (class-name super-name)
      (if
        (= class-name super-name)
        true
        (let
          ((rec (get registry class-name)))
          (if
            (nil? rec)
            false
            (some
              (fn (p) (clos-subclass-of? p super-name))
              (get rec "parents"))))))))

;; ── instance-of? ──────────────────────────────────────────────────────────

(define
  clos-instance-of?
  (fn (obj class-name) (clos-subclass-of? (clos-class-of obj) class-name)))

;; ── defclass ──────────────────────────────────────────────────────────────
;;
;; slot-specs: list of dicts with keys: name initarg initform accessor reader writer
;; Each missing key defaults to nil.

(define clos-slot-spec (fn (spec) (if (string? spec) {:initform nil :initarg nil :reader nil :writer nil :accessor nil :name spec} spec)))

(define
  clos-defclass
  (fn
    (name parents slot-specs)
    (let
      ((slots (dict)))
      (for-each
        (fn
          (pname)
          (let
            ((prec (get clos-class-registry pname)))
            (when
              (not (nil? prec))
              (for-each
                (fn
                  (k)
                  (when
                    (nil? (get slots k))
                    (dict-set! slots k (get (get prec "slots") k))))
                (keys (get prec "slots"))))))
        parents)
      (for-each
        (fn
          (s)
          (let
            ((spec (clos-slot-spec s)))
            (dict-set! slots (get spec "name") spec)))
        slot-specs)
      (let
        ((class-rec {:parents parents :clos-type "class" :slots slots :methods (list) :name name}))
        (dict-set! clos-class-registry name class-rec)
        (clos-install-accessors-for name slots)
        name))))

;; ── accessor installation (forward-declared, defined after defmethod) ──────

(define
  clos-install-accessors-for
  (fn
    (class-name slots)
    (for-each
      (fn
        (k)
        (let
          ((spec (get slots k)))
          (let
            ((reader (get spec "reader")))
            (when
              (not (nil? reader))
              (clos-add-reader-method reader class-name k)))
          (let
            ((accessor (get spec "accessor")))
            (when
              (not (nil? accessor))
              (clos-add-reader-method accessor class-name k)))))
      (keys slots))))

;; placeholder — real impl filled in after defmethod is defined
(define clos-add-reader-method (fn (method-name class-name slot-name) nil))

;; ── make-instance ─────────────────────────────────────────────────────────

(define
  clos-make-instance
  (fn
    (class-name &rest initargs)
    (let
      ((class-rec (get clos-class-registry class-name)))
      (if
        (nil? class-rec)
        (error (str "No class named: " class-name))
        (let
          ((slots (dict)))
          (for-each
            (fn
              (k)
              (let
                ((spec (get (get class-rec "slots") k)))
                (let
                  ((initform (get spec "initform")))
                  (when
                    (not (nil? initform))
                    (dict-set!
                      slots
                      k
                      (if (callable? initform) (initform) initform))))))
            (keys (get class-rec "slots")))
          (define
            apply-args
            (fn
              (args)
              (when
                (>= (len args) 2)
                (let
                  ((key (str (first args))) (val (first (rest args))))
                  (let
                    ((skey (if (= (slice key 0 1) ":") (slice key 1 (len key)) key)))
                    (let
                      ((matched false))
                      (for-each
                        (fn
                          (sk)
                          (let
                            ((spec (get (get class-rec "slots") sk)))
                            (let
                              ((ia (get spec "initarg")))
                              (when
                                (or
                                  (= ia key)
                                  (= ia (str ":" skey))
                                  (= sk skey))
                                (dict-set! slots sk val)
                                (set! matched true)))))
                        (keys (get class-rec "slots")))))
                  (apply-args (rest (rest args)))))))
          (apply-args initargs)
          {:clos-type "instance" :slots slots :class class-name})))))

;; ── slot-value ────────────────────────────────────────────────────────────

(define
  clos-slot-value
  (fn
    (instance slot-name)
    (if
      (and (dict? instance) (= (get instance "clos-type") "instance"))
      (get (get instance "slots") slot-name)
      (error (str "Not a CLOS instance: " (inspect instance))))))

(define
  clos-set-slot-value!
  (fn
    (instance slot-name value)
    (if
      (and (dict? instance) (= (get instance "clos-type") "instance"))
      (dict-set! (get instance "slots") slot-name value)
      (error (str "Not a CLOS instance: " (inspect instance))))))

(define
  clos-slot-boundp
  (fn
    (instance slot-name)
    (and
      (dict? instance)
      (= (get instance "clos-type") "instance")
      (not (nil? (get (get instance "slots") slot-name))))))

;; ── find-class / change-class ─────────────────────────────────────────────

(define clos-find-class (fn (name) (get clos-class-registry name)))

(define
  clos-change-class!
  (fn
    (instance new-class-name)
    (if
      (and (dict? instance) (= (get instance "clos-type") "instance"))
      (dict-set! instance "class" new-class-name)
      (error (str "Not a CLOS instance: " (inspect instance))))))

;; ── defgeneric ────────────────────────────────────────────────────────────

(define
  clos-defgeneric
  (fn
    (name options)
    (let
      ((combination (or (get options "method-combination") "standard")))
      (when
        (nil? (get clos-generic-registry name))
        (dict-set! clos-generic-registry name {:methods (list) :combination combination :name name}))
      name)))

;; ── defmethod ─────────────────────────────────────────────────────────────
;;
;; method-fn: (fn (args next-fn) body)
;;   args = list of all call arguments
;;   next-fn = (fn () next-method-result) or nil

(define
  clos-defmethod
  (fn
    (generic-name qualifiers specializers method-fn)
    (when
      (nil? (get clos-generic-registry generic-name))
      (clos-defgeneric generic-name {}))
    (let
      ((grec (get clos-generic-registry generic-name))
        (new-method {:fn method-fn :qualifiers qualifiers :specializers specializers}))
      (let
        ((kept (filter (fn (m) (not (and (= (get m "qualifiers") qualifiers) (= (get m "specializers") specializers)))) (get grec "methods"))))
        (dict-set!
          clos-generic-registry
          generic-name
          (assoc grec "methods" (append kept (list new-method))))
        generic-name))))

;; Now install the real accessor-method installer
(set!
  clos-add-reader-method
  (fn
    (method-name class-name slot-name)
    (clos-defmethod
      method-name
      (list)
      (list class-name)
      (fn (args next-fn) (clos-slot-value (first args) slot-name)))))

;; ── method specificity ─────────────────────────────────────────────────────

(define
  clos-method-matches?
  (fn
    (method args)
    (let
      ((specs (get method "specializers")))
      (if
        (> (len specs) (len args))
        false
        (define
          check-all
          (fn
            (i)
            (if
              (>= i (len specs))
              true
              (let
                ((spec (nth specs i)) (arg (nth args i)))
                (if
                  (= spec "t")
                  (check-all (+ i 1))
                  (if
                    (clos-instance-of? arg spec)
                    (check-all (+ i 1))
                    false))))))
        (check-all 0)))))

;; Precedence distance: how far class-name is from spec-name up the hierarchy.
(define
  clos-specificity
  (let
    ((registry clos-class-registry))
    (fn
      (class-name spec-name)
      (define
        walk
        (fn
          (cn depth)
          (if
            (= cn spec-name)
            depth
            (let
              ((rec (get registry cn)))
              (if
                (nil? rec)
                nil
                (let
                  ((results (map (fn (p) (walk p (+ depth 1))) (get rec "parents"))))
                  (let
                    ((non-nil (filter (fn (x) (not (nil? x))) results)))
                    (if
                      (empty? non-nil)
                      nil
                      (reduce
                        (fn (a b) (if (< a b) a b))
                        (first non-nil)
                        (rest non-nil))))))))))
      (walk class-name 0))))

(define
  clos-method-more-specific?
  (fn
    (m1 m2 args)
    (let
      ((s1 (get m1 "specializers")) (s2 (get m2 "specializers")))
      (define
        cmp
        (fn
          (i)
          (if
            (>= i (len s1))
            false
            (let
              ((c1 (clos-specificity (clos-class-of (nth args i)) (nth s1 i)))
                (c2
                  (clos-specificity (clos-class-of (nth args i)) (nth s2 i))))
              (cond
                ((and (nil? c1) (nil? c2)) (cmp (+ i 1)))
                ((nil? c1) false)
                ((nil? c2) true)
                ((< c1 c2) true)
                ((> c1 c2) false)
                (:else (cmp (+ i 1))))))))
      (cmp 0))))

(define
  clos-sort-methods
  (fn
    (methods args)
    (define
      insert
      (fn
        (m sorted)
        (if
          (empty? sorted)
          (list m)
          (if
            (clos-method-more-specific? m (first sorted) args)
            (cons m sorted)
            (cons (first sorted) (insert m (rest sorted)))))))
    (reduce (fn (acc m) (insert m acc)) (list) methods)))

;; ── call-generic (standard method combination) ─────────────────────────────

(define
  clos-call-generic
  (fn
    (generic-name args)
    (let
      ((grec (get clos-generic-registry generic-name)))
      (if
        (nil? grec)
        (error (str "No generic function: " generic-name))
        (let
          ((applicable (filter (fn (m) (clos-method-matches? m args)) (get grec "methods"))))
          (if
            (empty? applicable)
            (error
              (str
                "No applicable method for "
                generic-name
                " with classes "
                (inspect (map clos-class-of args))))
            (let
              ((primary (filter (fn (m) (empty? (get m "qualifiers"))) applicable))
                (before
                  (filter
                    (fn (m) (= (get m "qualifiers") (list "before")))
                    applicable))
                (after
                  (filter
                    (fn (m) (= (get m "qualifiers") (list "after")))
                    applicable))
                (around
                  (filter
                    (fn (m) (= (get m "qualifiers") (list "around")))
                    applicable)))
              (let
                ((sp (clos-sort-methods primary args))
                  (sb (clos-sort-methods before args))
                  (sa (clos-sort-methods after args))
                  (sw (clos-sort-methods around args)))
                (define
                  make-primary-chain
                  (fn
                    (methods)
                    (if
                      (empty? methods)
                      (fn
                        ()
                        (error (str "No next primary method: " generic-name)))
                      (fn
                        ()
                        ((get (first methods) "fn")
                          args
                          (make-primary-chain (rest methods)))))))
                (define
                  make-around-chain
                  (fn
                    (around-methods inner-thunk)
                    (if
                      (empty? around-methods)
                      inner-thunk
                      (fn
                        ()
                        ((get (first around-methods) "fn")
                          args
                          (make-around-chain
                            (rest around-methods)
                            inner-thunk))))))
                (for-each (fn (m) ((get m "fn") args (fn () nil))) sb)
                (let
                  ((primary-thunk (make-primary-chain sp)))
                  (let
                    ((result (if (empty? sw) (primary-thunk) ((make-around-chain sw primary-thunk)))))
                    (for-each
                      (fn (m) ((get m "fn") args (fn () nil)))
                      (reverse sa))
                    result))))))))))

;; ── call-next-method / next-method-p ──────────────────────────────────────

(define clos-call-next-method (fn (next-fn) (next-fn)))

(define clos-next-method-p (fn (next-fn) (not (nil? next-fn))))

;; ── with-slots ────────────────────────────────────────────────────────────

(define
  clos-with-slots
  (fn
    (instance slot-names body-fn)
    (let
      ((vals (map (fn (s) (clos-slot-value instance s)) slot-names)))
      (apply body-fn vals))))