;;;;;;;;;;;;;;;;;;;;;;;;; Display backtraces ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define tm-last-backtrace #f)

(define (backtrace-dumper key . args)
  ;; Internal function for backtrack
  (let ((stack (make-stack #t backtrace-dumper)))
    (set! tm-last-backtrace stack)
    (display-backtrace stack (current-error-port))
    (apply display-error stack (current-error-port) args)
    (apply throw (cons key args))))

(define-macro (backtrack . body)
  ;; Evaluate body and print a full stack backtrace if an error occurs.
  ;; Copied from:
  ;;   http://mail.gnu.org/archive/html/guile-user/2001-01/msg00126.html
  ;; For this to work, the user init file should start with:
  ;;   (debug-enable 'backtrace 'debug)
  ;; NOTE: this is a hack, the whole error reporting system of TeXmacs should
  ;;   be redesigned (well... not to say "designed to start with").
  ;; WARNING: has a problem coexisting with wrap-trace-level
  `(lazy-catch #t (lambda ()  ,@body) backtrace-dumper))

;;;;;;;;;;;;;;;;;;;;;;;;;;; Tracing calls ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;   Trace levels
;; Display parameters and return value of a function.
;; Increase the trace indentation to show the call hierarchy.
;; Do not preserve tail recursion.

(define trace-level 0)
(define (trace-indent)
  ;; Produce the string to be used to indent trace output.
  (let rec ((n trace-level) (s '()))
    (if (equal? 0 n) (apply string-append s)
	(rec (1- n) (cons "| " s)))))

(define (trace-display . args)
  ;; As display but also print trace indentation.
  (display (trace-indent))
  (for-each (lambda (a)
	      (display a)
	      (display " "))
	    args)
  (newline))

(define (wrap-trace name lam)
  (lambda args
    (trace-display
     (if (null? args)
	 (string-append "[" name "]")
	 (apply string-append
		`("[" ,name
		  ,@(map (lambda (x) (string-append " " (object->string x)))
			 args) "]"))))
    (set! trace-level (1+ trace-level))
    (catch #t
	   (lambda ()
	     (let ((res (apply lam args)))
	       (set! trace-level (1- trace-level))      
	       (trace-display (object->string res))
	       res))
	   (lambda err
	     (set! trace-level (1- trace-level))
	     (apply throw err)))))

(define-macro (set-trace-level! . names)
  ;; Make each function a trace-level. Functions can be set multiple
  ;; times, only the first application is effective.
  ;; Parameters are function names
  `(begin
     ,@(map (lambda (name)
	      `(if (not (procedure-property ,name 'trace-wrapped))
		   (begin
		     (set! ,name (wrap-trace ,(symbol->string name) ,name))
		     (set-procedure-property! ,name 'trace-wrapped #t))))
	    names)))