1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
|
#lang at-exp racket/base
(require racket/format
racket/match
(only-in racket/path path-only)
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 v)
(cond [(exn? v)
(unless (equal? "Check failure" (exn-message v)) ;rackunit check fails
(fresh-line)
(display-commented (fully-qualify-error-path str))
(display-srclocs v)
(unless (exn:fail:user? v)
(display-context v))
(maybe-suggest-packages v))]
[else
(fresh-line)
(display-commented str)]))
(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 here "error.rkt")
(define (system-context? ci)
(match-define (cons id src) ci)
(or (not src)
(let ([src (srcloc-source src)])
(and (path? src)
(or (equal? (path-only src) (path-only here))
(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/db get-catalogs]
[pkg/lib pkg-catalog-suggestions-for-module])
(λ (exn)
(when (exn:missing-module? exn)
(match (get-catalogs)
[(list)
(display-commented
@~a{-----
Can't suggest packages to install, because pkg/db get-catalogs is '().
To configure:
1. Start DrRacket.
2. Choose "File | Package Mananger".
3. Click "Available from Catalog".
4. When prompted, click "Update".
-----})]
[_
(define mod ((exn:missing-module-accessor exn) exn))
(match (pkg-catalog-suggestions-for-module mod)
[(list) void]
[(list p)
(display-commented
@~a{Try "raco pkg install @|p|" ?})]
[(? list? ps)
(display-commented
@~a{Try "raco pkg install" one of @(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))))))
|
