;; lib/common-lisp/tests/conditions.sx — Phase 3 condition system tests
;;
;; Loaded by lib/common-lisp/test.sh after:
;;   (load "spec/stdlib.sx")
;;   (load "lib/common-lisp/runtime.sx")
;;
;; Each test resets the handler/restart stacks to ensure isolation.

(define
  reset-stacks!
  (fn () (set! cl-handler-stack (list)) (set! cl-restart-stack (list))))

;; ── helpers ────────────────────────────────────────────────────────────────

(define passed 0)
(define failed 0)
(define failures (list))

(define
  assert-equal
  (fn
    (label got expected)
    (if
      (= got expected)
      (set! passed (+ passed 1))
      (begin
        (set! failed (+ failed 1))
        (set!
          failures
          (append
            failures
            (list
              (str
                "FAIL ["
                label
                "]: got="
                (inspect got)
                " expected="
                (inspect expected)))))))))

(define
  assert-true
  (fn
    (label got)
    (if
      got
      (set! passed (+ passed 1))
      (begin
        (set! failed (+ failed 1))
        (set!
          failures
          (append
            failures
            (list
              (str "FAIL [" label "]: expected true, got " (inspect got)))))))))

(define
  assert-nil
  (fn
    (label got)
    (if
      (nil? got)
      (set! passed (+ passed 1))
      (begin
        (set! failed (+ failed 1))
        (set!
          failures
          (append
            failures
            (list (str "FAIL [" label "]: expected nil, got " (inspect got)))))))))

;; ── 1. condition predicates ────────────────────────────────────────────────

(reset-stacks!)

(let
  ((c (cl-make-condition "simple-error" "format-control" "oops")))
  (begin
    (assert-true "cl-condition? on condition" (cl-condition? c))
    (assert-equal "cl-condition? on string" (cl-condition? "hello") false)
    (assert-equal "cl-condition? on number" (cl-condition? 42) false)
    (assert-equal "cl-condition? on nil" (cl-condition? nil) false)))

;; ── 2. cl-make-condition + slot access ────────────────────────────────────

(reset-stacks!)

(let
  ((c (cl-make-condition "simple-error" "format-control" "msg" "format-arguments" (list 1 2))))
  (begin
    (assert-equal "class field" (get c "class") "simple-error")
    (assert-equal "cl-type field" (get c "cl-type") "cl-condition")
    (assert-equal
      "format-control slot"
      (cl-condition-slot c "format-control")
      "msg")
    (assert-equal
      "format-arguments slot"
      (cl-condition-slot c "format-arguments")
      (list 1 2))
    (assert-nil "missing slot is nil" (cl-condition-slot c "no-such-slot"))
    (assert-equal "condition-message" (cl-condition-message c) "msg")))

;; ── 3. cl-condition-of-type? — hierarchy walking ─────────────────────────

(reset-stacks!)

(let
  ((se (cl-make-condition "simple-error" "format-control" "x"))
    (w (cl-make-condition "simple-warning" "format-control" "y"))
    (te
      (cl-make-condition
        "type-error"
        "datum"
        5
        "expected-type"
        "string"))
    (dz (cl-make-condition "division-by-zero")))
  (begin
    (assert-true
      "se isa simple-error"
      (cl-condition-of-type? se "simple-error"))
    (assert-true "se isa error" (cl-condition-of-type? se "error"))
    (assert-true
      "se isa serious-condition"
      (cl-condition-of-type? se "serious-condition"))
    (assert-true "se isa condition" (cl-condition-of-type? se "condition"))
    (assert-equal
      "se not isa warning"
      (cl-condition-of-type? se "warning")
      false)
    (assert-true
      "w isa simple-warning"
      (cl-condition-of-type? w "simple-warning"))
    (assert-true "w isa warning" (cl-condition-of-type? w "warning"))
    (assert-true "w isa condition" (cl-condition-of-type? w "condition"))
    (assert-equal "w not isa error" (cl-condition-of-type? w "error") false)
    (assert-true "te isa type-error" (cl-condition-of-type? te "type-error"))
    (assert-true "te isa error" (cl-condition-of-type? te "error"))
    (assert-true
      "dz isa division-by-zero"
      (cl-condition-of-type? dz "division-by-zero"))
    (assert-true
      "dz isa arithmetic-error"
      (cl-condition-of-type? dz "arithmetic-error"))
    (assert-true "dz isa error" (cl-condition-of-type? dz "error"))
    (assert-equal
      "non-condition not isa anything"
      (cl-condition-of-type? 42 "error")
      false)))

;; ── 4. cl-define-condition ────────────────────────────────────────────────

(reset-stacks!)

(begin
  (cl-define-condition "my-app-error" (list "error") (list "code" "detail"))
  (let
    ((c (cl-make-condition "my-app-error" "code" 404 "detail" "not found")))
    (begin
      (assert-true "user condition: cl-condition?" (cl-condition? c))
      (assert-true
        "user condition isa my-app-error"
        (cl-condition-of-type? c "my-app-error"))
      (assert-true
        "user condition isa error"
        (cl-condition-of-type? c "error"))
      (assert-true
        "user condition isa condition"
        (cl-condition-of-type? c "condition"))
      (assert-equal
        "user condition slot code"
        (cl-condition-slot c "code")
        404)
      (assert-equal
        "user condition slot detail"
        (cl-condition-slot c "detail")
        "not found"))))

;; ── 5. cl-handler-bind (non-unwinding) ───────────────────────────────────

(reset-stacks!)

(let
  ((log (list)))
  (begin
    (cl-handler-bind
      (list
        (list
          "error"
          (fn (c) (set! log (append log (list (cl-condition-message c)))))))
      (fn
        ()
        (cl-signal (cl-make-condition "simple-error" "format-control" "oops"))))
    (assert-equal "handler-bind: handler fired" log (list "oops"))))

(reset-stacks!)

;; Non-unwinding: body continues after signal
(let
  ((body-ran false))
  (begin
    (cl-handler-bind
      (list (list "error" (fn (c) nil)))
      (fn
        ()
        (cl-signal (cl-make-condition "simple-error" "format-control" "x"))
        (set! body-ran true)))
    (assert-true "handler-bind: body continues after signal" body-ran)))

(reset-stacks!)

;; Type filtering: warning handler does not fire for error
(let
  ((w-fired false))
  (begin
    (cl-handler-bind
      (list (list "warning" (fn (c) (set! w-fired true))))
      (fn
        ()
        (cl-signal (cl-make-condition "simple-error" "format-control" "e"))))
    (assert-equal
      "handler-bind: type filter (warning ignores error)"
      w-fired
      false)))

(reset-stacks!)

;; Multiple handlers: both matching handlers fire
(let
  ((log (list)))
  (begin
    (cl-handler-bind
      (list
        (list "error" (fn (c) (set! log (append log (list "e1")))))
        (list "condition" (fn (c) (set! log (append log (list "e2"))))))
      (fn
        ()
        (cl-signal (cl-make-condition "simple-error" "format-control" "x"))))
    (assert-equal "handler-bind: both handlers fire" log (list "e1" "e2"))))

(reset-stacks!)

;; ── 6. cl-handler-case (unwinding) ───────────────────────────────────────

;; Catches error, returns handler result
(let
  ((result (cl-handler-case (fn () (cl-error "boom") 99) (list "error" (fn (c) (str "caught: " (cl-condition-message c)))))))
  (assert-equal "handler-case: catches error" result "caught: boom"))

(reset-stacks!)

;; Returns body result when no signal
(let
  ((result (cl-handler-case (fn () 42) (list "error" (fn (c) -1)))))
  (assert-equal "handler-case: body result" result 42))

(reset-stacks!)

;; Only first matching handler runs (unwinding)
(let
  ((result (cl-handler-case (fn () (cl-error "x")) (list "simple-error" (fn (c) "simple")) (list "error" (fn (c) "error")))))
  (assert-equal "handler-case: most specific wins" result "simple"))

(reset-stacks!)

;; ── 7. cl-warn ────────────────────────────────────────────────────────────

(let
  ((warned false))
  (begin
    (cl-handler-bind
      (list (list "warning" (fn (c) (set! warned true))))
      (fn () (cl-warn "be careful")))
    (assert-true "cl-warn: fires warning handler" warned)))

(reset-stacks!)

;; Warn with condition object
(let
  ((msg ""))
  (begin
    (cl-handler-bind
      (list (list "warning" (fn (c) (set! msg (cl-condition-message c)))))
      (fn
        ()
        (cl-warn
          (cl-make-condition "simple-warning" "format-control" "take care"))))
    (assert-equal "cl-warn: condition object" msg "take care")))

(reset-stacks!)

;; ── 8. cl-restart-case + cl-invoke-restart ───────────────────────────────

;; Basic restart invocation
(let
  ((result (cl-restart-case (fn () (cl-invoke-restart "use-zero")) (list "use-zero" (list) (fn () 0)))))
  (assert-equal "restart-case: invoke-restart use-zero" result 0))

(reset-stacks!)

;; Restart with argument
(let
  ((result (cl-restart-case (fn () (cl-invoke-restart "use-value" 77)) (list "use-value" (list "v") (fn (v) v)))))
  (assert-equal "restart-case: invoke-restart with arg" result 77))

(reset-stacks!)

;; Body returns normally when restart not invoked
(let
  ((result (cl-restart-case (fn () 42) (list "never-used" (list) (fn () -1)))))
  (assert-equal "restart-case: body result" result 42))

(reset-stacks!)

;; ── 9. cl-with-simple-restart ─────────────────────────────────────────────

(let
  ((result (cl-with-simple-restart "skip" "Skip this step" (fn () (cl-invoke-restart "skip") 99))))
  (assert-nil "with-simple-restart: invoke returns nil" result))

(reset-stacks!)

;; ── 10. cl-find-restart ───────────────────────────────────────────────────

(let
  ((found (cl-restart-case (fn () (cl-find-restart "retry")) (list "retry" (list) (fn () nil)))))
  (assert-true "find-restart: finds active restart" (not (nil? found))))

(reset-stacks!)

(let
  ((not-found (cl-restart-case (fn () (cl-find-restart "nonexistent")) (list "retry" (list) (fn () nil)))))
  (assert-nil "find-restart: nil for inactive restart" not-found))

(reset-stacks!)

;; ── 11. cl-compute-restarts ───────────────────────────────────────────────

(let
  ((names (cl-restart-case (fn () (cl-restart-case (fn () (cl-compute-restarts)) (list "inner" (list) (fn () nil)))) (list "outer" (list) (fn () nil)))))
  (assert-equal
    "compute-restarts: both restarts"
    names
    (list "inner" "outer")))

(reset-stacks!)

;; ── 12. handler-bind + restart-case interop ───────────────────────────────

;; Classic CL pattern: error handler invokes a restart
(let
  ((result (cl-restart-case (fn () (cl-handler-bind (list (list "error" (fn (c) (cl-invoke-restart "use-zero")))) (fn () (cl-error "divide by zero")))) (list "use-zero" (list) (fn () 0)))))
  (assert-equal "interop: handler invokes restart" result 0))

(reset-stacks!)

;; ── 13. cl-cerror ─────────────────────────────────────────────────────────

;; When "continue" restart is invoked, cerror returns nil
(let
  ((result (cl-restart-case (fn () (cl-cerror "continue anyway" "something bad") 42) (list "continue" (list) (fn () "resumed")))))
  (assert-true
    "cerror: returns"
    (or (nil? result) (= result 42) (= result "resumed"))))

(reset-stacks!)

;; ── 14. slot accessor helpers ─────────────────────────────────────────────

(let
  ((c (cl-make-condition "simple-error" "format-control" "msg" "format-arguments" (list 1 2))))
  (begin
    (assert-equal
      "simple-condition-format-control"
      (cl-simple-condition-format-control c)
      "msg")
    (assert-equal
      "simple-condition-format-arguments"
      (cl-simple-condition-format-arguments c)
      (list 1 2))))

(let
  ((c (cl-make-condition "type-error" "datum" 42 "expected-type" "string")))
  (begin
    (assert-equal "type-error-datum" (cl-type-error-datum c) 42)
    (assert-equal
      "type-error-expected-type"
      (cl-type-error-expected-type c)
      "string")))

(let
  ((c (cl-make-condition "arithmetic-error" "operation" "/" "operands" (list 1 0))))
  (begin
    (assert-equal
      "arithmetic-error-operation"
      (cl-arithmetic-error-operation c)
      "/")
    (assert-equal
      "arithmetic-error-operands"
      (cl-arithmetic-error-operands c)
      (list 1 0))))


;; ── 15. *debugger-hook* ───────────────────────────────────────────────────

(reset-stacks!)

(let ((received nil))
  (begin
    (set! cl-debugger-hook
      (fn (c h)
        (set! received (cl-condition-message c))
        (cl-invoke-restart "escape")))
    (cl-restart-case
      (fn () (cl-error "debugger test"))
      (list "escape" (list) (fn () nil)))
    (set! cl-debugger-hook nil)
    (assert-equal "debugger-hook receives condition"  received  "debugger test")))

(reset-stacks!)

;; ── 16. *break-on-signals* ────────────────────────────────────────────────

(reset-stacks!)

(let ((triggered false))
  (begin
    (set! cl-break-on-signals "error")
    (set! cl-debugger-hook
      (fn (c h)
        (set! triggered true)
        (cl-invoke-restart "abort")))
    (cl-restart-case
      (fn ()
        (cl-signal (cl-make-condition "simple-error" "format-control" "x")))
      (list "abort" (list) (fn () nil)))
    (set! cl-break-on-signals nil)
    (set! cl-debugger-hook nil)
    (assert-true "break-on-signals fires hook"  triggered)))

(reset-stacks!)

;; break-on-signals: non-matching type does NOT fire hook
(let ((triggered false))
  (begin
    (set! cl-break-on-signals "error")
    (set! cl-debugger-hook
      (fn (c h) (set! triggered true) nil))
    (cl-handler-bind
      (list (list "warning" (fn (c) nil)))
      (fn ()
        (cl-signal (cl-make-condition "simple-warning" "format-control" "w"))))
    (set! cl-break-on-signals nil)
    (set! cl-debugger-hook nil)
    (assert-equal "break-on-signals: type mismatch not triggered"  triggered  false)))

(reset-stacks!)

;; ── 17. cl-invoke-restart-interactively ──────────────────────────────────

(let ((result
        (cl-restart-case
          (fn () (cl-invoke-restart-interactively "use-default"))
          (list "use-default" (list) (fn () 99)))))
  (assert-equal "invoke-restart-interactively: returns restart value"  result  99))

(reset-stacks!)

;; ── summary ────────────────────────────────────────────────────────────────

(if
  (= failed 0)
  (print (str "ok " passed "/" (+ passed failed) " condition tests passed"))
  (begin
    (for-each (fn (f) (print f)) failures)
    (print
      (str "FAIL " passed "/" (+ passed failed) " passed, " failed " failed"))))