forked from greghendershott/racket-mode
-
Notifications
You must be signed in to change notification settings - Fork 0
/
run.rkt
194 lines (180 loc) · 8.26 KB
/
run.rkt
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
#lang racket/base
(require racket/cmdline
racket/contract/base
racket/contract/region
racket/format
racket/match
racket/runtime-path
racket/pretty
"channel.rkt"
"cmds.rkt"
"error.rkt"
"gui.rkt"
"instrument.rkt"
"logger.rkt"
"mod.rkt"
"older-racket.rkt"
"util.rkt")
(module+ main
(command-line #:args (command-output-file)
(current-command-output-file command-output-file))
;; Emacs on Windows comint-mode needs buffering disabled.
(when (eq? (system-type 'os) 'windows)
(file-stream-buffer-mode (current-output-port) 'none))
(display (banner))
(flush-output)
(parameterize ([error-display-handler our-error-display-handler])
(run rerun-default)))
(define (run rr) ;rerun? -> void?
(match-define (rerun maybe-mod mem-limit pretty-print? context-level) rr)
(define-values (dir file mod-path) (maybe-mod->dir/file/rmp maybe-mod))
;; Always set current-directory and current-load-relative-directory
;; to match the source file.
(current-directory dir)
(current-load-relative-directory dir)
;; Make src-loc->string provide full pathnames
(show-full-path-in-errors)
;; Custodian for the REPL.
(define repl-cust (make-custodian))
(when mem-limit
(custodian-limit-memory repl-cust
(inexact->exact (round (* 1024 1024 mem-limit)))
repl-cust))
;; If racket/gui/base isn't loaded, the current-eventspace parameter
;; doesn't exist, so make a "dummy" parameter of that name.
(define current-eventspace (txt/gui (make-parameter #f) current-eventspace))
;; Create REPL thread
(define repl-thread
(parameterize* ;; Use `parameterize*` because the order matters.
(;; FIRST: current-custodian and current-namespace, so in
;; effect for later parameterizations.
[current-custodian repl-cust]
[current-namespace ((txt/gui make-base-namespace make-gui-namespace))]
;; OTHERS:
[compile-enforce-module-constants #f]
[compile-context-preservation-enabled (not (eq? context-level 'low))]
[current-eval (if (instrument-level? context-level)
(make-instrumented-eval-handler (current-eval))
(current-eval))]
[instrumenting-enabled (instrument-level? context-level)]
[profiling-enabled (eq? context-level 'profile)]
[test-coverage-enabled (eq? context-level 'coverage)]
;; LAST: `current-eventspace` because `make-eventspace`
;; creates an event handler thread -- now. We want that
;; thread to inherit the parameterizations above. (Otherwise
;; in the non-gui case, we call `thread` below in the body of
;; the parameterize* form, so that's fine.)
[current-eventspace ((txt/gui void make-eventspace))])
;; repl-thunk will be called from another thread -- either a plain
;; thread when racket/gui/base is not (yet) instantiated, or, from
;; (eventspace-handler-thread (current-eventspace)).
(define (repl-thunk)
;; 0. Set current-print and pretty-print hooks.
(current-print (make-print-handler pretty-print?))
(pretty-print-print-hook (make-pretty-print-print-hook))
(pretty-print-size-hook (make-pretty-print-size-hook))
;; 1. Start logger display thread.
(start-log-receiver)
;; 2. If module, load its lang info, require, and enter its namespace.
(when mod-path
(parameterize ([current-module-name-resolver repl-module-name-resolver])
;; exn:fail? during module load => re-run with "empty" module
(with-handlers ([exn? (λ (x)
(display-exn x)
(put/stop (struct-copy rerun rr [maybe-mod #f])))])
(maybe-warn-about-submodules mod-path context-level)
(maybe-load-language-info mod-path)
(dynamic-require mod-path #f)
(current-namespace (module->namespace mod-path))
(check-top-interaction))))
;; 3. read-eval-print-loop
(parameterize ([current-prompt-read (make-prompt-read maybe-mod)]
[current-module-name-resolver repl-module-name-resolver])
;; Note that read-eval-print-loop catches all non-break
;; exceptions.
(read-eval-print-loop)))
;; Main thread: Run repl-thunk on a plain thread, or, on the
;; eventspace thread via queue-callback. Return the thread.
(define t/v ((txt/gui thread queue-callback ) repl-thunk))
(define thd ((txt/gui (λ _ t/v) eventspace-handler-thread) (current-eventspace)))
thd))
;; Main thread: Wait for message from REPL thread on channel. Also
;; catch breaks, in which case we (a) break the REPL thread so
;; display-exn runs there, and (b) continue from the break instead
;; of re-running so that the REPL environment is maintained.
(define msg
(call-with-exception-handler
(match-lambda
[(and (or (? exn:break:terminate?) (? exn:break:hang-up?)) e) e]
[(exn:break msg marks continue) (break-thread repl-thread) (continue)]
[e e])
(λ () (sync the-channel))))
(match context-level
['profile (clear-profile-info!)]
['coverage (clear-test-coverage-info!)]
[_ (void)])
(custodian-shutdown-all repl-cust)
(newline) ;; FIXME: Move this to racket-mode.el instead?
(match msg
[(? rerun? x) (run x)]
[(? load-gui?) (require-gui) (run rr)]))
(define (maybe-load-language-info path)
;; Load language-info (if any) and do configure-runtime.
;; Important for langs like Typed Racket.
(define info (module->language-info path #t))
(when info
(define get-info ((dynamic-require (vector-ref info 0)
(vector-ref info 1))
(vector-ref info 2)))
(define configs (get-info 'configure-runtime '()))
(for ([config (in-list configs)])
((dynamic-require (vector-ref config 0)
(vector-ref config 1))
(vector-ref config 2)))
(define cr-submod `(submod ,path configure-runtime))
(when (module-declared? cr-submod)
(dynamic-require cr-submod #f))))
(define (check-top-interaction)
;; Check that the lang defines #%top-interaction
(unless (memq '#%top-interaction (namespace-mapped-symbols))
(error 'repl "The module's language provides no `#%top-interaction' and\ncannot be used in a REPL.")))
;; Catch attempt to load racket/gui/base for the first time.
(define repl-module-name-resolver
(let ([orig-resolver (current-module-name-resolver)])
(case-lambda
[(rmp ns)
(orig-resolver rmp ns)]
[(mp rmp stx)
(repl-module-name-resolver mp rmp stx #t)]
[(mp rmp stx load?)
(when (and load? (memq mp '(racket/gui/base
racket/gui/dynamic
scheme/gui/base)))
(unless (gui-required?)
(put/stop (load-gui))))
(orig-resolver mp rmp stx load?)])))
;; Note: The `dynamic-require`s seem to be necessary otherwise
;; file/convertible's convertible? always returns #f. Which seeems to
;; be a namespace issue that I don't understand.
(define-runtime-path image.rkt "image.rkt")
(define (make-print-handler pretty-print?)
(cond [pretty-print? pretty-print-handler]
[else (make-plain-print-handler)]))
(define (make-plain-print-handler)
(let ([convert (dynamic-require image.rkt 'convert-image)])
(λ (v)
(void (unless (void? v)
(print (convert v))
(newline))))))
(define (make-pretty-print-size-hook [orig (pretty-print-size-hook)])
(let ([convert? (dynamic-require image.rkt 'convert-image?)]
[width (floor (/ (pretty-print-columns) 4))]) ;magic number? yep.
(λ (value display? port)
(cond [(convert? value) width]
[else (orig value display? port)]))))
(define (make-pretty-print-print-hook [orig (pretty-print-print-hook)])
(let ([convert? (dynamic-require image.rkt 'convert-image?)]
[convert (dynamic-require image.rkt 'convert-image)])
(λ (value display? port)
(cond [(convert? value) (print (convert value) port)]
[else (orig value display? port)]))))