;; Reflection accessors: Object>>class, class>>name, class>>superclass,
;; class>>methodDict, class>>selectors. Phase 4 starting point.

(set! st-test-pass 0)
(set! st-test-fail 0)
(set! st-test-fails (list))

(st-bootstrap-classes!)
(define ev (fn (src) (smalltalk-eval src)))
(define evp (fn (src) (smalltalk-eval-program src)))

;; ── 1. Object>>class on native receivers ──
(st-test "42 class name"        (ev "42 class name")     "SmallInteger")
(st-test "3.14 class name"      (ev "3.14 class name")   "Float")
(st-test "'hi' class name"      (ev "'hi' class name")   "String")
(st-test "#foo class name"      (ev "#foo class name")   "Symbol")
(st-test "true class name"      (ev "true class name")   "True")
(st-test "false class name"     (ev "false class name")  "False")
(st-test "nil class name"       (ev "nil class name")    "UndefinedObject")
(st-test "$a class name"        (ev "$a class name")     "String")
(st-test "#(1 2 3) class name"  (ev "#(1 2 3) class name") "Array")
(st-test "[42] class name"      (ev "[42] class name")   "BlockClosure")

;; ── 2. Object>>class on user instances ──
(st-class-define! "Cat" "Object" (list "name"))
(st-test "user instance class name"
  (evp "^ Cat new class name") "Cat")
(st-test "user instance class superclass name"
  (evp "^ Cat new class superclass name") "Object")

;; ── 3. class>>name / class>>superclass ──
(st-test "class>>name on Object" (ev "Object name") "Object")
(st-test "class>>superclass on Object" (ev "Object superclass") nil)
(st-test "class>>superclass on Symbol"
  (ev "Symbol superclass name") "String")
(st-test "class>>superclass on String"
  (ev "String superclass name") "ArrayedCollection")

;; ── 4. class>>class returns Metaclass ──
(st-test "Cat class is Metaclass"
  (ev "Cat class name") "Metaclass")

;; ── 5. class>>methodDict ──
(st-class-add-method! "Cat" "miaow" (st-parse-method "miaow ^ #miaow"))
(st-class-add-method! "Cat" "purr"  (st-parse-method "purr ^ #purr"))

(st-test
  "methodDict has expected keys"
  (sort (keys (ev "Cat methodDict")))
  (sort (list "miaow" "purr")))

(st-test
  "methodDict size after two adds"
  (len (keys (ev "Cat methodDict")))
  2)

;; ── 6. class>>selectors ──
(st-test
  "selectors returns Array of symbols"
  (sort (map (fn (s) (str s)) (ev "Cat selectors")))
  (sort (list "miaow" "purr")))

;; ── 7. class>>instanceVariableNames ──
(st-test "instance variable names"
  (ev "Cat instanceVariableNames") (list "name"))

(st-class-define! "Kitten" "Cat" (list "age"))
(st-test "subclass own ivars"
  (ev "Kitten instanceVariableNames") (list "age"))
(st-test "subclass allInstVarNames includes inherited"
  (ev "Kitten allInstVarNames") (list "name" "age"))

;; ── 8. methodDict reflects new methods ──
(st-class-add-method! "Cat" "scratch" (st-parse-method "scratch ^ #scratch"))
(st-test "methodDict updated after add"
  (len (keys (ev "Cat methodDict"))) 3)

;; ── 9. classMethodDict / classSelectors ──
(st-class-add-class-method! "Cat" "named:"
  (st-parse-method "named: aName ^ self new"))
(st-test "classSelectors"
  (map (fn (s) (str s)) (ev "Cat classSelectors")) (list "named:"))

;; ── 10. Method records are usable values ──
(st-test "methodDict at: returns method record dict"
  (dict? (get (ev "Cat methodDict") "miaow")) true)

(list st-test-pass st-test-fail)