;;; Guile Knots
;;; Copyright © 2026 Christopher Baines <mail@cbaines.net>
;;;
;;; This file is part of Guile Knots.
;;;
;;; The Guile Knots is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; The Guile Knots is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with the guix-data-service.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (knots backtraces)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-43)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (system repl debug)
  #:use-module (system vm frame)
  #:use-module ((knots) #:select (display/knots
                                  simple-format/knots
                                  format/knots))
  #:export (&knots-exception
            make-knots-exception
            knots-exception?
            knots-exception-stack

            print-backtrace-and-exception/knots))

(define &knots-exception
  (make-exception-type '&knots-exception
                       &exception
                       '(stack)))

(define make-knots-exception
  (record-constructor &knots-exception))
(set-procedure-property! make-knots-exception 'documentation
  "Construct a @code{&knots-exception} with the given stack.")

(define knots-exception?
  (exception-predicate &knots-exception))
(set-procedure-property! knots-exception? 'documentation
  "Return @code{#t} if OBJ is a @code{&knots-exception}.")

(define knots-exception-stack
  (exception-accessor
   &knots-exception
   (record-accessor &knots-exception 'stack)))
(set-procedure-property! knots-exception-stack 'documentation
  "Return the stack from a @code{&knots-exception}.")

(define (backtrace-debug-mode?)
  (let ((val (getenv "KNOTS_BACKTRACE_DEBUG")))
    (and val
         (not (string=? val ""))
         (not (string=? val "0")))))

(define (debug-print-stack port label full-vec included-vec)
  (simple-format/knots port "[KNOTS DEBUG] ~A\n" label)
  (if (vector-empty? full-vec)
      (simple-format/knots port "  (empty)\n")
      (vector-fold-right
       (lambda (i _ frame)
         (let ((marker
                (if (vector-index
                     (lambda (f) (eq? f frame))
                     included-vec)
                    ">" " "))
               (name
                (symbol->string
                 (or (frame-procedure-name frame)
                     '_))))
           (match (frame-source frame)
             (#f
              (format/knots port "  ~a ~3d  unknown  ~a~%"
                            marker i name))
             ((_ file line . col)
              (format/knots port "  ~a ~3d  ~a:~a:~a  ~a~%"
                            marker i file (1+ line) col name)))))
       #f
       full-vec))
  (force-output port))

(define (internal-file? file)
  (or (string-prefix? "ice-9/" file)
      (string-prefix? "system/" file)
      (string-prefix? "srfi/" file)
      (string=? file "knots.scm")
      (string-prefix? "knots/" file)
      (string=? file "fibers.scm")
      (string-prefix? "fibers/" file)))

(define (frame-file frame)
  (let ((src (frame-source frame)))
    (and src (cadr src))))

(define (user-frame? frame)
  (let ((file (frame-file frame)))
    (and (string? file)
         (not (internal-file? file)))))

(define (raise-machinery-frame? frame)
  ;; Return #t for frames that are part of the raise/unwind machinery
  ;; and should be skipped when looking for the raise site.
  ;; Specifically: C/unknown frames (no source file) and
  ;; ice-9/boot-9.scm frames.  Other internal frames such as
  ;; ice-9/vlist.scm are part of the actual call path and should be
  ;; preserved.
  (let ((file (frame-file frame)))
    (or (not file)
        (string=? file "ice-9/boot-9.scm"))))

(define (fibers-frame? frame)
  ;; Return #t if FRAME belongs to the fibers library.
  (let ((file (frame-file frame)))
    (and (string? file)
         (or (string=? file "fibers.scm")
             (string-prefix? "fibers/" file)))))

;; The number of frames in Guile's eval-machinery tail appended to every
;; top-level script stack:
;;
;;   [n-6]  ice-9/boot-9.scm       _
;;   [n-5]  ice-9/boot-9.scm       save-module-excursion
;;   [n-4]  ice-9/eval.scm         _
;;   [n-3]  ice-9/boot-9.scm       call-with-prompt
;;   [n-2]  C/unknown              apply-smob/0
;;   [n-1]  ice-9/boot-9.scm       with-exception-handler
(define script-eval-tail-length 6)

(define (classify-stack-situation stack-vector)
  (cond
   ((vector-any fibers-frame? stack-vector)
    'run-fibers)
   ((let ((len (vector-length stack-vector)))
      (and (>= len script-eval-tail-length)
           (equal? (frame-file (vector-ref stack-vector (- len 1)))
                   "ice-9/boot-9.scm")
           (eq? (frame-procedure-name (vector-ref stack-vector (- len 3)))
                'call-with-prompt)
           (not (vector-any (lambda (frame)
                              (eq? (frame-procedure-name frame)
                                   '%start-stack))
                            stack-vector))))
    'script)
   (else
    'unknown)))

(define (filter-knots-stack-vector vector)
  ;; Extract user frames from a pre-captured knots stack.  The bottom 3 frames
  ;; are always fixed overhead: make-stack (C), the handler body frame at the
  ;; make-stack call site (exactly 1 Scheme frame), and raise-exception
  ;; (boot-9).  User frames start at index 3.
  (let ((last-user (vector-index-right user-frame? vector)))
    (if (or (not last-user) (< last-user 3))
        #()
        (vector-copy vector 3 (+ last-user 1)))))

(define (filter-stack-vector vector)
  ;; Return the slice of VECTOR containing the frames relevant for
  ;; display.  Skips the fixed 2-frame overhead (make-stack + call
  ;; site) and any raise machinery to find after-raise, then bounds at
  ;; the eval-machinery tail (script) or the first fibers scheduler
  ;; frame (run-fibers/unknown).

  (define (skip-handler-and-raise vector start)
    ;; Scan forward from START in VECTOR, first past any user frames
    ;; (the handler body), then past raise-machinery frames (C/unknown
    ;; and ice-9/boot-9.scm).  Returns the index of the first
    ;; remaining frame — the raise site or context.  Other internal
    ;; frames such as ice-9/vlist.scm are preserved because they are
    ;; part of the actual call path.
    (let* ((len (vector-length vector))
           (after-handler
            (let loop ((i start))
              (if (or (>= i len) (not (user-frame? (vector-ref vector i))))
                  i
                  (loop (+ i 1))))))
      (let loop ((i after-handler))
        (cond
         ((>= i len) i)
         ((raise-machinery-frame? (vector-ref vector i)) (loop (+ i 1)))
         (else i)))))

  (let* ((len         (vector-length vector))
         (situation   (classify-stack-situation vector))
         (after-raise (skip-handler-and-raise vector (min 2 len)))
         (end         (if (and (eq? situation 'script)
                               (> (- len script-eval-tail-length) after-raise))
                          (- len script-eval-tail-length)
                          (let loop ((i after-raise))
                            (cond ((>= i len) i)
                                  ((fibers-frame? (vector-ref vector i)) i)
                                  (else (loop (+ i 1))))))))
    (if (>= after-raise end)
        #()
        (vector-copy vector after-raise end))))

;; Based on print-frame from (system repl debug), but without the
;; frame indexes
(define* (print-frame/no-index frame
                               #:optional (port (current-output-port))
                               #:key (width (terminal-width))
                               (last-source #f) (innermost? #f))
  (define (source-file src)
    (match src
      (#f "unknown file")
      ((_ #f . _) "current input")
      ((_ file . _) file)))
  (let* ((source (frame-source frame))
         (file   (source-file source)))
    (when (not (equal? file (source-file last-source)))
      (format port "~&In ~a:~&" file))
    (format port "~9@a    ~v:@y~%"
            (match source
              (#f "")
              ((_ _ line . col) (simple-format #f "~A:~A" (1+ line) col)))
            width
            (frame-call-representation frame #:top-frame? innermost?))))

(define* (print-backtrace-and-exception/knots
          exn
          #:key (port (current-error-port)))
  "Print the backtrace and exception information from EXN to PORT. This
procedure captures the stack, so should be run before the stack is
unwound, so using @code{with-exception-handler} without
@code{#:unwind? #t}, the exception may need to then be re-raised and
handled in an outer exception handler.

@example
(with-exception-handler
    (lambda (exn)
      ;; Recover from the exception
      #f)
  (lambda ()
    (with-exception-handler
        (lambda (exn)
          (print-backtrace-and-exception/knots exn)
          (raise-exception exn))
      (lambda ()
        (do-things))))
  #:unwind? #t)
@end example

It's important to use @code{print-backtrace-and-exception/knots} for
displaying backtraces involving functionality from Guile Knots, since
the stack involved is potentially split across several fibers. The
stacks involved are attached to the exception, and this procedure
extracts this information out and assembles a backtrace including all
the code involved.
"
  (define (get-string out stack)
    (let* ((stack-vector (stack->vector stack))
           (knots-stack-vectors
            (map (lambda (exn)
                   (stack->vector
                    (knots-exception-stack exn)))
                 (reverse
                  (filter knots-exception?
                          (simple-exceptions exn)))))
           (filtered-stack-vector
            (filter-stack-vector stack-vector))
           (filtered-knots-stack-vectors
            (map filter-knots-stack-vector knots-stack-vectors)))
      (when (backtrace-debug-mode?)
        (let ((debug-port (current-error-port))
              (situation (classify-stack-situation stack-vector)))
          (simple-format/knots
           debug-port
           "[KNOTS DEBUG] situation: ~A\n" situation)
          (debug-print-stack debug-port "stack"
                             stack-vector filtered-stack-vector)
          (let ((stack-count (length knots-stack-vectors)))
            (for-each
             (lambda (knots-vec user-vec index)
               (debug-print-stack
                debug-port
                (format #f "knots stack ~a/~a" index stack-count)
                knots-vec user-vec))
             knots-stack-vectors
             filtered-knots-stack-vectors
             (iota stack-count 1)))
          (display/knots "\n" debug-port)
          (force-output debug-port)))

      (for-each (lambda (vec)
                  (vector-fold-right
                   (lambda (i last-source frame)
                     (print-frame/no-index frame out
                                           #:innermost? (= i 0)
                                           #:last-source last-source)
                     (frame-source frame))
                   #f
                   vec))
                (cons filtered-stack-vector
                      filtered-knots-stack-vectors))

      (print-exception
       out
       #f
       '%exception
       (list (if (backtrace-debug-mode?)
                 exn
                 (apply make-exception
                        (remove knots-exception?
                                (simple-exceptions exn))))))))

  (let* ((stack
          (match (fluid-ref %stacks)
            ((stack-tag . prompt-tag)
             (make-stack #t
                         0 prompt-tag
                         0 (and prompt-tag 1)))
            (_
             (make-stack #t))))
         (string-port
          (open-output-string))
         (output
          (with-exception-handler
              (lambda (output-exn)
                (display/knots (get-output-string string-port)
                               port)
                (close-output-port string-port)
                (display/knots "\n\n" port)

                (let* ((stack (make-stack #t))
                       (backtrace
                        (call-with-output-string
                          (lambda (port)
                            (display-backtrace stack port)
                            (newline port)))))
                  (display/knots backtrace port))
                (simple-format/knots
                 port
                 "\nexception in print-backtrace-and-exception/knots: ~A\n"
                 output-exn)
                (raise-exception output-exn))
            (lambda ()
              (get-string string-port stack)
              (let ((str (get-output-string string-port)))
                (close-output-port string-port)
                str)))))
    (display/knots output port)))