rose-ash/lib/common-lisp/tests/programs/interactive-debugger.sx

;; interactive-debugger.sx — Condition debugger using *debugger-hook*
;;
;; Demonstrates the classic CL debugger pattern:
;;   - *debugger-hook* is invoked when an unhandled error reaches the top level
;;   - The hook receives the condition and a reference to itself
;;   - It can offer restarts interactively (here simulated with a policy fn)
;;
;; In real CL the debugger reads from the terminal. Here we simulate
;; the "user input" via a policy function passed in at call time.
;;
;; Depends on: lib/common-lisp/runtime.sx already loaded.

;; ── *debugger-hook* global ────────────────────────────────────────────────
;;
;; CL: when error is unhandled, invoke *debugger-hook* with (condition hook).
;; A nil hook means use the system default (which we simulate as re-raise).

(define cl-debugger-hook nil)

;; ── invoke-debugger ────────────────────────────────────────────────────────
;;
;; Called when cl-error finds no handler. Tries cl-debugger-hook first;
;; falls back to a simple error report.

(define
  cl-invoke-debugger
  (fn
    (c)
    (if
      (nil? cl-debugger-hook)
      (error (str "Debugger: " (cl-condition-message c)))
      (begin
        (let
          ((hook cl-debugger-hook))
          (set! cl-debugger-hook nil)
          (let
            ((result (hook c hook)))
            (set! cl-debugger-hook hook)
            result))))))

;; ── cl-error/debugger — error that routes through invoke-debugger ─────────

(define
  cl-error-with-debugger
  (fn
    (c &rest args)
    (let
      ((obj (cond ((cl-condition? c) c) ((string? c) (cl-make-condition "simple-error" "format-control" c "format-arguments" args)) (:else (cl-make-condition "simple-error" "format-control" (str c))))))
      (cl-signal-obj obj cl-handler-stack)
      (cl-invoke-debugger obj))))

;; ── simulated debugger session ────────────────────────────────────────────
;;
;; A debugger hook takes (condition hook) and "reads" user commands.
;; We simulate this with a policy function: (fn (c restarts) restart-name)
;; that picks a restart given the condition and available restarts.

(define
  make-policy-debugger
  (fn
    (policy)
    (fn
      (c hook)
      (let
        ((available (cl-compute-restarts)))
        (let
          ((choice (policy c available)))
          (if
            (and choice (not (nil? (cl-find-restart choice))))
            (cl-invoke-restart choice)
            (error
              (str
                "Debugger: no restart chosen for: "
                (cl-condition-message c)))))))))

;; ── tests ─────────────────────────────────────────────────────────────────

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

(define
  check
  (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
  reset-stacks!
  (fn
    ()
    (set! cl-handler-stack (list))
    (set! cl-restart-stack (list))
    (set! cl-debugger-hook nil)))

;; Test 1: debugger hook receives condition
(reset-stacks!)
(let
  ((received-msg ""))
  (begin
    (set!
      cl-debugger-hook
      (fn (c hook) (set! received-msg (cl-condition-message c)) nil))
    (cl-restart-case
      (fn () (cl-error-with-debugger "something broke"))
      (list "abort" (list) (fn () nil)))
    (check "debugger hook receives condition" received-msg "something broke")))

;; Test 2: policy-driven restart selection (use-zero)
(reset-stacks!)
(let
  ((result (begin (set! cl-debugger-hook (make-policy-debugger (fn (c restarts) "use-zero"))) (cl-restart-case (fn () (cl-error-with-debugger (cl-make-condition "division-by-zero")) 999) (list "use-zero" (list) (fn () 0))))))
  (check "policy debugger: use-zero restart" result 0))

;; Test 3: policy selects abort
(reset-stacks!)
(let
  ((result (begin (set! cl-debugger-hook (make-policy-debugger (fn (c restarts) "abort"))) (cl-restart-case (fn () (cl-error-with-debugger "aborting error") 999) (list "abort" (list) (fn () "aborted"))))))
  (check "policy debugger: abort restart" result "aborted"))

;; Test 4: compute-restarts inside debugger hook
(reset-stacks!)
(let
  ((seen-restarts (list)))
  (begin
    (set!
      cl-debugger-hook
      (fn
        (c hook)
        (set! seen-restarts (cl-compute-restarts))
        (cl-invoke-restart "continue")))
    (cl-restart-case
      (fn () (cl-error-with-debugger "test") 42)
      (list "continue" (list) (fn () "ok"))
      (list "abort" (list) (fn () "no")))
    (check
      "debugger: compute-restarts visible"
      (= (len seen-restarts) 2)
      true)))

;; Test 5: hook not invoked when handler catches first
(reset-stacks!)
(let
  ((hook-called false)
    (result
      (begin
        (set! cl-debugger-hook (fn (c hook) (set! hook-called true) nil))
        (cl-handler-case
          (fn () (cl-error-with-debugger "handled"))
          (list "error" (fn (c) "handler-won"))))))
  (check "handler wins; hook not called" hook-called false)
  (check "handler result returned" result "handler-won"))

;; Test 6: debugger-hook nil after re-raise guard
(reset-stacks!)
(let
  ((hook-calls 0))
  (begin
    (set!
      cl-debugger-hook
      (fn
        (c hook)
        (set! hook-calls (+ hook-calls 1))
        (if
          (> hook-calls 1)
          (error "infinite loop guard")
          (cl-invoke-restart "escape"))))
    (cl-restart-case
      (fn () (cl-error-with-debugger "once"))
      (list "escape" (list) (fn () nil)))
    (check
      "hook called exactly once (no infinite recursion)"
      hook-calls
      1)))

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

(define debugger-passed passed)
(define debugger-failed failed)
(define debugger-failures failures)