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
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
|
#lang at-exp racket/base
(require (only-in pkg/db
get-catalogs)
(only-in pkg/lib
pkg-catalog-suggestions-for-module
pkg-directory)
racket/format
racket/match
racket/string
setup/dirs
"instrument.rkt"
"stack-checkpoint.rkt"
"util.rkt")
(provide display-exn
racket-mode-error-display-handler
prevent-path-elision-by-srcloc->string)
(module+ test
(require rackunit))
(define (display-exn exn)
(racket-mode-error-display-handler (exn-message exn) exn))
(define (racket-mode-error-display-handler str v)
(cond [(exn? v)
(unless (equal? "Check failure" (exn-message v)) ;rackunit check fails
(display-commented (complete-paths
(undo-path->relative-string/library str)))
(display-srclocs v)
(unless (exn:fail:user? v)
(display-context v))
(maybe-suggest-packages v))]
[else
(display-commented str)]))
;;; srclocs
(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)))))
(module+ test
(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) "")))
;; We don't use source-location->string from syntax/srcloc, because we
;; don't want the setup/path-to-relative behavior that elides complete
;; pathnames with prefixes like "<pkgs>/" etc. For strings we create
;; ourselves, we use our own such function, defined here.
(define (source-location->string x)
(define src
;; Although I want to find/fix this properly upstream -- is
;; something a path-string? when it should be a path? -- for now
;; just catch here the case where the source is a string like
;; "\"/path/to/file.rkt\"" i.e. the string value has quotes.
(match (srcloc-source x)
[(pregexp "^\"(.+)\"$" (list _ unquoted)) unquoted]
[v v]))
(define line (or (srcloc-line x) 1))
(define col (or (srcloc-column x) 0))
(format "~a:~a:~a" src line col))
;;; context
(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 (~a "Context (errortrace):" s))])]
[else
(match (context->string
(continuation-mark-set->trimmed-context
(exn-continuation-marks exn)))
["" (void)]
[s (display-commented
(~a "Context (plain; to see better errortrace context, re-run with C-u prefix):\n"
s))])]))
(define (context->string xs)
(string-join (for/list ([x xs]
[_ (error-print-context-length)])
(context-item->string x))
"\n"))
(define (context-item->string ci)
(match-define (cons id srcloc) ci)
(~a (if (or srcloc id) " " "")
(if srcloc (source-location->string srcloc) "")
(if (and srcloc id) " " "")
(if id (format "~a" id) "")))
;;; Complete pathnames for Emacs
;; The background here is that want source locations in error messages
;; to use complete pathnames ("complete" as in complete-path? a.k.a.
;; "absolute" plus drive letter on Windows). That way, Emacs features
;; like compilation-mode's next-error command will work nicely.
;;
;; - When we create strings from srclocs, ourselves: We create them
;; that way. See source-location->string defined/used in this file.
;;
;; - When other things create strings from scrlocs: We try to prevent
;; them from eliding in the first place. And since we can't always
;; prevent, we try to undo any elision baked into the error message
;; by the time we get it. As a sanity check, we don't transform
;; things into complete pathnames unless the result actually exists.
;; srcloc->string from racket/base uses current-directory-for-user to
;; elide paths. Setting that to 'pref-dir -- where it is very unlikely
;; a user's source file will be -- should prevent it from eliding
;; anything.
(define (prevent-path-elision-by-srcloc->string)
(current-directory-for-user (find-system-path 'pref-dir)))
;; The source-location->string function provided by syntax/srcloc uses
;; path->relative-string/library to elide paths with prefixes like
;; <pkgs>/ or <collects>/. We avoid using that function in this
;; module, for example in display-srclocs and in context-item->string
;; above. However things like racket/contract use syntax/srcloc and
;; those prefixes might be baked into exn-message. Here we try to undo
;; this for things that look like such source locations.
(define (undo-path->relative-string/library s)
(regexp-replace*
#px"(<(.+?)>/(.+?)):(\\d+[:.]\\d+)"
s
(λ (_ prefix+rel-path prefix rel-path line+col)
(define (f dir [rel rel-path])
(existing (simplify-path (build-path dir rel))))
(~a (or (and (path-string? rel-path)
(match prefix
["collects" (f (find-collects-dir))]
["user" (f (find-user-collects-dir))]
["doc" (f (find-doc-dir))]
["user-doc" (f (find-user-doc-dir))]
["pkgs" (match rel-path
[(pregexp "^(.+?)/(.+?)$" (list _ pkg-name more))
(f (pkg-directory pkg-name) more)]
[_ #f])]
[_ #f]))
prefix+rel-path) ;keep as-is
":" line+col))))
(module+ test
(check-equal? (undo-path->relative-string/library "<collects>/racket/file.rkt:1:0:")
(~a (build-path (find-collects-dir) "racket" "file.rkt") ":1:0:"))
(check-equal? (undo-path->relative-string/library "<doc>/2d/index.html:1:0:")
(~a (build-path (find-doc-dir) "2d" "index.html") ":1:0:"))
;; Note: No test for <user-doc> because unlikely to work on Travis CI
(let ([non-existing "<collects>/racket/does-not-exist.rkt:1:0 blah blah blah"])
(check-equal? (undo-path->relative-string/library non-existing)
non-existing
"does not change to non-existing pathname")))
(module+ test
(let ()
(local-require racket/path
setup/path-to-relative
drracket/find-module-path-completions)
(define-values (_links _paths pkg-dirs)
(alternate-racket-clcl/clcp (find-system-path 'exec-file) (box #f)))
(printf "Checking .rkt files in ~v packages...\n" (length pkg-dirs))
(define c (make-hash))
(for ([item (in-list pkg-dirs)])
(match item
[(list (? string?) (? path? dir))
(for ([p (in-directory dir)]
#:when (equal? #".rkt" (path-get-extension p)))
(define complete (~a p ":1.0"))
(define relative (~a (path->relative-string/library p #:cache c) ":1.0"))
(define undone (undo-path->relative-string/library relative))
(check-equal? undone complete))]
[_ (void)]))))
;; If this looks like a source location where the pathname is
;; relative, prepend current-directory if that results in an actually
;; existing file.
(define (complete-paths s)
(regexp-replace*
#px"([^:]+):(\\d+[:.]\\d+)"
s
(λ (_ orig-path line+col)
(~a (or (and (relative-path? orig-path)
(existing (build-path (current-directory) orig-path)))
orig-path)
":" line+col))))
(define (existing p)
(and (path? p) (file-exists? p) p))
(module+ test
(let ()
(local-require racket/file
racket/path)
(define temp-dir (find-system-path 'temp-dir))
(define example (make-temporary-file "racket-mode-test-~a" #f temp-dir))
(define name (file-name-from-path example))
(parameterize ([current-directory temp-dir])
(let ([suffix ":3:0: f: unbound identifier\n in: f"])
(check-equal? (complete-paths (~a name suffix))
(~a (build-path temp-dir name) suffix)
"relative path: curdir prepended when that is an existing file"))
(let ([msg (~a example ":3:0: f: unbound identifier\n in: f")])
(check-equal? (complete-paths msg)
msg
"already complete path: no change")))
(delete-file example)))
;;; packages
(define (maybe-suggest-packages 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 Manager".
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])])))
|
