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
|
;;; racket-cmd.el -*- lexical-binding: t; -*-
;; Copyright (c) 2013-2020 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Image portions Copyright (C) 2012 Jose Antonio Ortega Ruiz.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
;; License:
;; This is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version. This is distributed in the hope that it will be
;; useful, but without any warranty; without even the implied warranty
;; of merchantability or fitness for a particular purpose. See the GNU
;; General Public License for more details. See
;; http://www.gnu.org/licenses/ for details.
;;; Back end command server process
(require 'racket-custom)
(require 'racket-util)
(declare-function racket--debug-on-break "racket-debug" (response))
(autoload 'racket--debug-on-break "racket-debug")
(declare-function racket--logger-on-notify "racket-logger" (str))
(autoload 'racket--logger-on-notify "racket-logger")
;;;###autoload
(defun racket-start-back-end ()
"Start the back end process used by Racket Mode.
If the process is already started, this command will stop and restart it."
(interactive)
(racket--cmd-open))
;;;###autoload
(defun racket-stop-back-end ()
"Stop the back end process used by Racket Mode.
If the process is not already started, this does nothing."
(interactive)
(racket--cmd-close))
(defconst racket--cmd-process-name "racket-mode-back-end"
"Used to name the process and its associated buffer.")
(defun racket--cmd-open-p ()
"Does a running process exist for the command server?"
(pcase (get-process racket--cmd-process-name)
((and (pred (processp)) proc)
(eq 'run (process-status proc)))))
(defvar racket--run.rkt (expand-file-name "main.rkt" racket--rkt-source-dir)
"Pathname of run.rkt.")
(defvar racket-adjust-run-rkt #'identity
"A function used to transform the variable `racket--run.rkt'.
You probably don't need to change this unless you are developing
Racket Mode, AND run Emacs on Windows Subsystem for Linux, AND
want to run your programs using Windows Racket.exe, AND have the
Racket Mode source code under \"/mnt\". Whew. In that case you
can set this variable to the function `racket-wsl-to-windows' so
that Racket Mode can find its own run.rkt file.")
(defvar racket--cmd-auth nil
"A value we give the Racket back-end when we launch it and when we connect.
See issue #327.")
(defun racket--cmd-open ()
(racket--cmd-close) ;never create multi processes e.g. "racket-process<1>"
(make-process
:name racket--cmd-process-name
:connection-type 'pipe
:noquery t
:coding 'utf-8
:buffer (get-buffer-create (concat " *" racket--cmd-process-name "*"))
:stderr (make-pipe-process
:name (concat racket--cmd-process-name "-stderr")
:buffer nil
:noquery t
:coding 'utf-8
:filter #'racket--cmd-process-stderr-filter
:sentinel #'ignore)
:command (list racket-program
(funcall racket-adjust-run-rkt racket--run.rkt)
(setq racket--cmd-auth (let ((print-length nil) ;for %S
(print-level nil))
(format "%S" `(auth ,(random)))))
(if (and (boundp 'image-types)
(fboundp 'image-type-available-p)
(or (and (memq 'svg image-types)
(image-type-available-p 'svg))
(and (memq 'imagemagick image-types)
(image-type-available-p 'imagemagick))))
"--use-svg"
"--do-not-use-svg"))
:filter #'racket--cmd-process-filter))
(defun racket--cmd-close ()
(pcase (get-process racket--cmd-process-name)
((and (pred (processp)) proc) (delete-process proc))))
(defun racket--cmd-process-stderr-filter (proc string)
"Show back end process stderr via `message'.
Won't show noise like \"process finished\" if process sentinel is
`ignore'."
(message "{%s} %s\n" proc string))
(defun racket--cmd-process-filter (proc string)
"Parse complete sexprs from the process output and give them to
`racket--cmd-dispatch-response'."
(let ((buffer (process-buffer proc)))
(when (buffer-live-p buffer)
(with-current-buffer buffer
(goto-char (point-max))
(insert string)
(goto-char (point-min))
(while (pcase (ignore-errors (read buffer))
(`nil `nil)
(sexp (delete-region (point-min)
(if (eq (char-after) ?\n)
(1+ (point))
(point)))
(racket--cmd-dispatch-response sexp)
t)))))))
(defvar racket--cmd-nonce->callback (make-hash-table :test 'eq)
"A hash from nonce to callback function.")
(defvar racket--cmd-nonce 0
"Number that increments for each command request we send.")
(defun racket--cmd-dispatch-response (response)
"Do something with a sexpr sent to us from the command server.
Mostly these are responses to command requests. Strictly speaking
'logger and 'debug-break are \"notifications\", i.e. /not/ one
direct response to one command request."
(pcase response
(`(logger ,str)
(run-at-time 0.001 nil #'racket--logger-on-notify str))
(`(debug-break . ,response)
(run-at-time 0.001 nil #'racket--debug-on-break response))
(`(,nonce . ,response)
(let ((callback (gethash nonce racket--cmd-nonce->callback)))
(when callback
(remhash nonce racket--cmd-nonce->callback)
(run-at-time 0.001 nil callback response))))
(_ nil)))
(defun racket--cmd/async-raw (repl-session-id command-sexpr &optional callback)
"Send COMMAND-SEXPR and return. Later call CALLBACK with the response sexp.
REPL-SESSION-ID may be nil for commands that do not need to run
in a specific namespace.
If CALLBACK is not supplied or nil, defaults to `ignore'.
Otherwise CALLBACK is called after the command server returns a
response. Because command responses are obtained from the dynamic
extent of a `set-process-filter' proc -- which may have
limitations on what it can or should do -- CALLBACK is not called
immediately but instead using `run-at-time' with a very small
delay.
Important: Do not assume that `current-buffer' is the same when
CALLBACK is called, as it was when the command was sent. If you
need to do something to do that original buffer, save the
`current-buffer' in a `let' and use it in a `with-current-buffer'
form. See `racket--restoring-current-buffer'."
(unless (racket--cmd-open-p)
(racket--cmd-open))
(cl-incf racket--cmd-nonce)
(when (and callback
(not (equal callback #'ignore)))
(puthash racket--cmd-nonce callback racket--cmd-nonce->callback))
(process-send-string
(get-process racket--cmd-process-name)
(let ((print-length nil) ;for %S
(print-level nil))
(format "%S\n" `(,racket--cmd-nonce ,repl-session-id . ,command-sexpr)))))
(defun racket--cmd/async (repl-session-id command-sexpr &optional callback)
"You probably want to use this instead of `racket--cmd/async-raw'.
REPL-SESSION-ID may be nil for commands that do not need to run
in a specific namespace.
CALLBACK is only called for 'ok responses, with (ok v ...)
unwrapped to (v ...).
'error responses are handled here. Note: We use `message' not
`error' here because:
1. It would show \"error running timer:\" which, although true,
is confusing or at best N/A for end users.
2. More simply, we don't need to escape any call stack, we only
need to ... not call the callback!
'break responses are handled here, too. This is used when a
command is somehow canceled, with no useful response except the
indication we should clean up the pending callback as usual.
The original value of `current-buffer' is temporarily restored
during CALLBACK, because neglecting to do so is a likely
mistake."
(let ((buf (current-buffer)))
(racket--cmd/async-raw
repl-session-id
command-sexpr
(if callback
(lambda (response)
(pcase response
(`(ok ,v) (with-current-buffer buf (funcall callback v)))
(`(error ,m) (message "%s" m))
(`(break) nil)
(v (let ((print-length nil) ;for %S
(print-level nil))
(message "Unknown command response: %S" v)))))
#'ignore))))
(defun racket--cmd/await (repl-session-id command-sexpr)
"Send COMMAND-SEXPR. Await and return an 'ok response value, or raise `error'.
REPL-SESSION-ID may be nil for commands that do not need to run
in a specific namespace."
(let* ((awaiting 'RACKET-REPL-AWAITING)
(response awaiting))
(racket--cmd/async-raw repl-session-id
command-sexpr
(lambda (v) (setq response v)))
(with-timeout (racket-command-timeout
(error "racket-command process timeout"))
(while (eq response awaiting)
(accept-process-output nil 0.001))
(pcase response
(`(ok ,v) v)
(`(error ,m) (error "%s" m))
(v (let ((print-length nil) ;for %S
(print-level nil))
(error "Unknown command response: %S" v)))))))
(provide 'racket-cmd)
;; racket-cmd.el ends here
|
