181 lines
6.7 KiB
Racket
181 lines
6.7 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/match
|
|
racket/runtime-path
|
|
racket/string
|
|
setup/collects
|
|
setup/dirs
|
|
"fresh-line.rkt"
|
|
"instrument.rkt"
|
|
"util.rkt")
|
|
|
|
(provide display-exn
|
|
our-error-display-handler
|
|
show-full-path-in-errors)
|
|
|
|
(module+ test
|
|
(require rackunit))
|
|
|
|
(define (display-exn exn)
|
|
(our-error-display-handler (exn-message exn) exn))
|
|
|
|
(define (our-error-display-handler str exn)
|
|
(when (exn? exn)
|
|
(unless (equal? "Check failure" (exn-message exn)) ;rackunit check fails
|
|
(fresh-line)
|
|
(display-commented (fully-qualify-error-path str))
|
|
(display-srclocs exn)
|
|
(unless (exn:fail:user? exn)
|
|
(display-context exn))
|
|
(maybe-suggest-packages exn))))
|
|
|
|
(define (display-srclocs exn)
|
|
(when (exn:srclocs? exn)
|
|
(define srclocs
|
|
(match ((exn:srclocs-accessor exn) exn)
|
|
;; Some exceptions like exn:fail:read? include the first
|
|
;; srcloc in exn-message -- don't show it again.
|
|
[(cons _ xs)
|
|
#:when (or (exn:fail:read? exn)
|
|
(exn:fail:contract:variable? exn))
|
|
xs]
|
|
;; Some exceptions like exn:fail:syntax? with Typed Racket
|
|
;; include _all_ in exn-message -- don't show _any_.
|
|
[_
|
|
#:when (exn:fail:syntax? exn)
|
|
'()]
|
|
[xs xs]))
|
|
(for ([s (in-list srclocs)])
|
|
(display-commented (source-location->string s)))))
|
|
|
|
(define (display-context exn)
|
|
(cond [(instrumenting-enabled)
|
|
(define p (open-output-string))
|
|
(print-error-trace p exn)
|
|
(match (get-output-string p)
|
|
["" (void)]
|
|
[s (display-commented (string-append "Context (errortrace):"
|
|
;; et prepends a \n
|
|
s))])]
|
|
[else
|
|
(match (context->string
|
|
(continuation-mark-set->context (exn-continuation-marks exn)))
|
|
["" (void)]
|
|
[s (display-commented (string-append "Context:\n"
|
|
s))])]))
|
|
|
|
(define (context->string xs)
|
|
;; Limit the context in two ways:
|
|
;; 1. Don't go beyond error-print-context-length
|
|
;; 2. Don't go into "system" context that's just noisy.
|
|
(string-join (for/list ([x xs]
|
|
[_ (error-print-context-length)]
|
|
#:unless (system-context? x))
|
|
(context-item->string x))
|
|
"\n"))
|
|
|
|
(define-runtime-path run.rkt "run.rkt")
|
|
(define-runtime-path namespace.rkt "namespace.rkt")
|
|
(define (system-context? ci)
|
|
(match-define (cons id src) ci)
|
|
(or (not src)
|
|
(let ([src (srcloc-source src)])
|
|
(and (path? src)
|
|
(or (equal? src run.rkt)
|
|
(equal? src namespace.rkt)
|
|
(under-system-path? src))))))
|
|
|
|
(define (under-system-path? path)
|
|
(match (path->collects-relative path)
|
|
[`(collects #"mred" . ,_) #t]
|
|
[`(collects #"racket" #"contract" . ,_) #t]
|
|
[`(collects #"racket" #"private" . ,_) #t]
|
|
[`(collects #"typed-racket" . ,_) #t]
|
|
[_ #f]))
|
|
|
|
(define (context-item->string ci)
|
|
(match-define (cons id src) ci)
|
|
(string-append (if (or src id) " " "")
|
|
(if src (source-location->string src) "")
|
|
(if (and src id) " " "")
|
|
(if id (format "~a" id) "")))
|
|
|
|
;; Don't use source-location->string from syntax/srcloc. Don't want
|
|
;; the setup/path-to-relative behavior that replaces full pathnames
|
|
;; with <collects>, <pkgs> etc. Instead want full pathnames for Emacs'
|
|
;; compilation-mode. HOWEVER note that <collects> or <pkgs> might be
|
|
;; baked into exn-message string already; we handle that in
|
|
;; `fully-qualify-error-path`. Here we handle only strings we create
|
|
;; ourselves, such as for the Context "stack trace".
|
|
(define (source-location->string x)
|
|
(match-define (srcloc src line col pos span) x)
|
|
(format "~a:~a:~a" src (or line "1") (or col "1")))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Fully qualified pathnames in error messages, so that Emacs
|
|
;; compilation-mode can do its stuff.
|
|
|
|
;; srcloc->string uses current-directory-for-user to shorten error
|
|
;; messages. But we always want full pathnames. Setting it to
|
|
;; 'pref-dir -- very unlikely user .rkt file will be there -- is
|
|
;; least-worst way AFAIK.
|
|
(define (show-full-path-in-errors)
|
|
(current-directory-for-user (find-system-path 'pref-dir)))
|
|
|
|
;; If this looks like a Racket error message, but the filename is
|
|
;; not fully-qualified, prepend curdir to the filename.
|
|
;;
|
|
;; This covers Racket 5.3.6 and earlier. In fact, this might be
|
|
;; sufficient for _all_ versions of Racket and we don't need the
|
|
;; `show-full-path-in-errors` thing above, at all. Not yet sure.
|
|
(define (fully-qualify-error-path s)
|
|
(match s
|
|
[(pregexp "^([^/.]+)\\.([^.]+):(\\d+)[:.](\\d+):(.*)$"
|
|
(list _ base ext line col more))
|
|
(define curdir (path->string (current-directory)))
|
|
(string-append curdir base "." ext ":" line ":" col ":" more)]
|
|
[s (regexp-replace* #rx"<collects>"
|
|
s
|
|
(path->string (find-collects-dir)))]))
|
|
|
|
(module+ test
|
|
(require rackunit)
|
|
(check-equal?
|
|
(parameterize ([current-directory "/tmp/"])
|
|
(fully-qualify-error-path "foo.rkt:3:0: f: unbound identifier\n in: f"))
|
|
"/tmp/foo.rkt:3:0: f: unbound identifier\n in: f")
|
|
(check-equal?
|
|
(fully-qualify-error-path "/tmp/foo.rkt:3:0: f: unbound identifier\n in: f")
|
|
"/tmp/foo.rkt:3:0: f: unbound identifier\n in: f")
|
|
(let ([o (open-output-string)])
|
|
(parameterize ([current-error-port o])
|
|
(display-srclocs (make-exn:fail:read "..."
|
|
(current-continuation-marks)
|
|
'())))
|
|
(check-equal? (get-output-string o) "")))
|
|
|
|
(define maybe-suggest-packages
|
|
(with-handlers ([exn:fail? (λ _ void)])
|
|
(with-dynamic-requires ([racket/base exn:missing-module?]
|
|
[racket/base exn:missing-module-accessor]
|
|
[pkg/lib pkg-catalog-suggestions-for-module])
|
|
(λ (exn)
|
|
(when (exn:missing-module? exn)
|
|
(define mod ((exn:missing-module-accessor exn) exn))
|
|
(match (pkg-catalog-suggestions-for-module mod)
|
|
[(list) void]
|
|
[(list p)
|
|
(display-commented (format "Try `raco pkg install ~a`?" p))]
|
|
[(? list? ps)
|
|
(display-commented (format "Try `raco pkg install` one of ~a?"
|
|
(string-join ps ", ")))]
|
|
[_ void]))))))
|
|
|
|
(module+ test
|
|
;; Point of this test is older Rackets where the with-handlers
|
|
;; clause is exercised.
|
|
(check-not-exn
|
|
(λ ()
|
|
(maybe-suggest-packages (exn:fail "" (current-continuation-marks))))))
|