12f99702b4
Whether a program is on the other end is the one fact worth a permanent place on screen, because every command in the client is a lie without it. Until now it was discovered by something failing, which is the worst moment to learn it. Three states, not two. `off' is never connected; `lost' is a daemon that has gone away, which is the ordinary case rather than an error — `flan dev' ends when its program does, and a program under development exits all the time. So `lost' is reconnected from, on the socket it was on, the next time anything is sent. The reconnect is strictly *before* a send and never after one. A connection that dies mid-request might have died after the daemon took the request and ran it; resending would install a definition twice, or evaluate a side-effecting expression twice. That case now reports what happened and says it was not resent, rather than silently doing it again. A socket that is not there is refused by name with the path, and a deliberate `flan-disconnect' forgets the socket, so the next command says "not connected" instead of quietly reopening what was just closed.
454 lines
20 KiB
EmacsLisp
454 lines
20 KiB
EmacsLisp
;;; flan-dev.el --- Talk to a running Flan program -*- lexical-binding: t; -*-
|
|
|
|
;; The editor half of Flan's dev loop. `flan dev program.flan' compiles the
|
|
;; program, launches it, and listens on .flan-dev.sock beside the source; this
|
|
;; connects to that socket and sends it forms.
|
|
;;
|
|
;; C-c C-c recompiles the top-level form at point and installs it in the
|
|
;; running program, at that program's next frame boundary. Call sites compiled
|
|
;; before the new body existed follow it, and the program's state — its globals
|
|
;; — is untouched. C-c C-k does the same for a whole buffer.
|
|
;;
|
|
;; The protocol is one s-expression per message, length framed. That is why
|
|
;; there is no parser here: `prin1' writes a request and `read' reads a reply.
|
|
;;
|
|
;; C-x C-e evaluates the expression before point *in the running program* and
|
|
;; shows its value. That is a different primitive from redefining a name:
|
|
;; there is nothing to install a body into, so the expression is wrapped in a
|
|
;; thunk the program runs at its next frame boundary. Only scalars, bool and
|
|
;; strings render so far — a Flan value carries no header, so a printer has to
|
|
;; be derived per type at compile time, and the ones that are not derived yet
|
|
;; say so rather than guessing.
|
|
|
|
;;; Code:
|
|
|
|
(require 'subr-x)
|
|
(require 'seq)
|
|
(require 'pcase)
|
|
|
|
(defgroup flan-dev nil
|
|
"Talking to a running Flan program."
|
|
:group 'flan
|
|
:prefix "flan-dev-")
|
|
|
|
(defcustom flan-dev-socket-name ".flan-dev.sock"
|
|
"Name of the socket `flan dev' listens on, looked for up from the buffer."
|
|
:type 'string)
|
|
|
|
(defcustom flan-dev-echo-result t
|
|
"Whether a successful evaluation reports in the echo area."
|
|
:type 'boolean)
|
|
|
|
(defcustom flan-dev-output-buffer "*flan-output*"
|
|
"Buffer the running program's own output is appended to."
|
|
:type 'string)
|
|
|
|
(defvar flan-dev--connection nil
|
|
"The open connection, or nil.")
|
|
|
|
(defvar flan-dev--socket nil
|
|
"Path of the socket `flan-dev--connection' is connected to.")
|
|
|
|
;;; Wire
|
|
|
|
;; Framing is a decimal byte count, a newline, then that many bytes. A message
|
|
;; carries Flan source, which contains newlines, so a line-oriented protocol
|
|
;; would need an escape layer that this does not. Lengths are in *bytes*, so
|
|
;; every measurement goes through `string-bytes' and the process is raw-text —
|
|
;; a multibyte identifier would otherwise put the reply stream out of step by
|
|
;; exactly as many bytes as the payload has non-ASCII characters.
|
|
|
|
(defun flan-dev--send (proc form)
|
|
"Send FORM to PROC as one framed message."
|
|
(let* ((payload (encode-coding-string (prin1-to-string form) 'utf-8 t)))
|
|
(process-send-string proc (format "%d\n%s" (length payload) payload))))
|
|
|
|
(defun flan-dev--read-reply (proc)
|
|
"Block until PROC sends one complete framed message, and read it."
|
|
(with-current-buffer (process-buffer proc)
|
|
(let ((deadline (+ (float-time) 30)))
|
|
;; The header first: digits up to a newline.
|
|
(while (and (not (save-excursion (goto-char (point-min))
|
|
(re-search-forward "\\`\\([0-9]+\\)\n" nil t)))
|
|
(< (float-time) deadline))
|
|
(accept-process-output proc 0.05))
|
|
(goto-char (point-min))
|
|
(unless (re-search-forward "\\`\\([0-9]+\\)\n" nil t)
|
|
;; Deliberately not retried. If the daemon took the request and died
|
|
;; before replying, the evaluation may well have happened — sending it
|
|
;; again would install it twice, or run a side-effecting expression
|
|
;; twice. Reconnecting happens before a send, never after one.
|
|
(if (process-live-p proc)
|
|
(error "flan dev: no reply in 30s from %s"
|
|
(abbreviate-file-name (or flan-dev--socket "the daemon")))
|
|
(error
|
|
"flan dev: the daemon on %s closed the connection; not resent, because it may already have run"
|
|
(abbreviate-file-name (or flan-dev--socket "?")))))
|
|
(let* ((n (string-to-number (match-string 1)))
|
|
(body-start (point)))
|
|
(while (and (< (- (position-bytes (point-max)) (position-bytes body-start)) n)
|
|
(< (float-time) deadline))
|
|
(accept-process-output proc 0.05))
|
|
(let* ((end (byte-to-position (+ (position-bytes body-start) n)))
|
|
(text (decode-coding-string
|
|
(encode-coding-string (buffer-substring-no-properties
|
|
body-start end)
|
|
'utf-8 t)
|
|
'utf-8))
|
|
(form (car (read-from-string text))))
|
|
(delete-region (point-min) end)
|
|
form)))))
|
|
|
|
(defun flan-dev--append-output (text)
|
|
"Append TEXT, the running program's own output, to its buffer."
|
|
(when (and text (> (length text) 0))
|
|
(with-current-buffer (get-buffer-create flan-dev-output-buffer)
|
|
(let ((at-end (= (point) (point-max))))
|
|
(save-excursion
|
|
(goto-char (point-max))
|
|
(insert text))
|
|
;; Follow the tail only for someone who was already at it; a reader
|
|
;; scrolled back is reading something.
|
|
(when at-end (goto-char (point-max)))))))
|
|
|
|
(defun flan-dev--request (form)
|
|
"Send FORM to the connected program and return its reply."
|
|
(let* ((proc (flan-dev--live-connection))
|
|
(reply (progn (flan-dev--send proc form)
|
|
(flan-dev--read-reply proc))))
|
|
;; Whatever the program printed since the last reply rides along with this
|
|
;; one, so the output an evaluation itself caused arrives with its result.
|
|
(flan-dev--append-output (plist-get reply :output))
|
|
reply))
|
|
|
|
;;; Connection
|
|
|
|
(defun flan-dev--find-socket ()
|
|
"Find the daemon's socket by walking up from the current buffer."
|
|
(let ((dir (locate-dominating-file
|
|
(or buffer-file-name default-directory)
|
|
flan-dev-socket-name)))
|
|
(and dir (expand-file-name flan-dev-socket-name dir))))
|
|
|
|
(defun flan-dev--open (socket)
|
|
"Open a connection to SOCKET and make it the current one."
|
|
(when (process-live-p flan-dev--connection)
|
|
(delete-process flan-dev--connection))
|
|
(let ((buf (get-buffer-create " *flan-dev*")))
|
|
;; Unibyte, because the framing counts bytes and this buffer is where they
|
|
;; are counted.
|
|
(with-current-buffer buf (erase-buffer) (set-buffer-multibyte nil))
|
|
(setq flan-dev--connection
|
|
(make-network-process
|
|
:name "flan-dev" :buffer buf :family 'local :service socket
|
|
:coding 'binary :noquery t))
|
|
(setq flan-dev--socket socket))
|
|
(force-mode-line-update t)
|
|
flan-dev--connection)
|
|
|
|
;; A daemon restarted while Emacs was not looking is the ordinary case, not an
|
|
;; exceptional one: `flan dev' ends when its program does, and a program under
|
|
;; development exits all the time. So a dead connection is reopened on the
|
|
;; socket it was on rather than reported — but only *before* a request goes
|
|
;; out. Reconnecting after one has been sent and lost would be a retry, and a
|
|
;; retry of `eval-expr' runs the expression a second time.
|
|
(defun flan-dev--live-connection ()
|
|
"The open connection, reconnecting if the daemon has been restarted."
|
|
(unless (process-live-p flan-dev--connection)
|
|
(cond
|
|
((null flan-dev--socket)
|
|
(error "Not connected: M-x flan-connect, or start `flan dev program.flan'"))
|
|
((not (file-exists-p flan-dev--socket))
|
|
(setq flan-dev--connection nil)
|
|
(force-mode-line-update t)
|
|
(error "flan dev: nothing is listening on %s; start `flan dev program.flan' again"
|
|
(abbreviate-file-name flan-dev--socket)))
|
|
(t
|
|
(condition-case err
|
|
(progn (flan-dev--open flan-dev--socket)
|
|
(message "flan dev: reconnected to %s"
|
|
(abbreviate-file-name flan-dev--socket)))
|
|
(error
|
|
(setq flan-dev--connection nil)
|
|
(force-mode-line-update t)
|
|
(error "flan dev: cannot reconnect to %s: %s"
|
|
(abbreviate-file-name flan-dev--socket)
|
|
(error-message-string err)))))))
|
|
flan-dev--connection)
|
|
|
|
;;;###autoload
|
|
(defun flan-connect (&optional socket)
|
|
"Connect to a `flan dev' daemon listening on SOCKET.
|
|
With no argument, look for `flan-dev-socket-name' up from this buffer."
|
|
(interactive
|
|
(list (or (flan-dev--find-socket)
|
|
(read-file-name "flan dev socket: "))))
|
|
(unless socket (user-error "No %s found above this buffer" flan-dev-socket-name))
|
|
(flan-dev--open socket)
|
|
(let ((r (flan-dev--request '(:op "describe"))))
|
|
(message "flan dev: connected to %s (%d functions, %d globals)"
|
|
(abbreviate-file-name socket)
|
|
(length (plist-get r :fns)) (length (plist-get r :globals))))
|
|
flan-dev--connection)
|
|
|
|
(defun flan-disconnect ()
|
|
"Close the connection, which also ends the daemon and its program."
|
|
(interactive)
|
|
(when (process-live-p flan-dev--connection)
|
|
(ignore-errors (flan-dev--request '(:op "close")))
|
|
(delete-process flan-dev--connection))
|
|
(setq flan-dev--connection nil)
|
|
;; Forgotten, not kept: this was a deliberate disconnect, so the next
|
|
;; request should say so rather than quietly reopening what was just closed.
|
|
(setq flan-dev--socket nil)
|
|
(force-mode-line-update t)
|
|
(message "flan dev: disconnected"))
|
|
|
|
;;; The modeline
|
|
|
|
;; Whether there is a program on the other end is the one thing worth a
|
|
;; permanent place on screen, because every other command in here is a lie
|
|
;; without it. Before this it was discovered by a command failing.
|
|
|
|
(defface flan-dev-live-face '((t :inherit success))
|
|
"Face for the modeline indicator when a program is connected."
|
|
:group 'flan-dev)
|
|
|
|
(defface flan-dev-lost-face '((t :inherit warning))
|
|
"Face for the modeline indicator when the daemon has gone away."
|
|
:group 'flan-dev)
|
|
|
|
(defun flan-dev-state ()
|
|
"Whether a program is connected: `live', `lost', or `off'.
|
|
`lost' means there was one and the daemon is gone — a restart away, not a
|
|
mistake, so it is distinguished from never having connected."
|
|
(cond ((process-live-p flan-dev--connection) 'live)
|
|
(flan-dev--socket 'lost)
|
|
(t 'off)))
|
|
|
|
(defun flan-dev-mode-line ()
|
|
"The Flan connection indicator, for `mode-line-misc-info'."
|
|
(when (derived-mode-p 'flan-mode 'flan-repl-mode)
|
|
(pcase (flan-dev-state)
|
|
('live (propertize " flan:live" 'face 'flan-dev-live-face
|
|
'help-echo (format "Connected to %s" flan-dev--socket)))
|
|
('lost (propertize " flan:lost" 'face 'flan-dev-lost-face
|
|
'help-echo
|
|
(format "%s has gone away; the next command reconnects"
|
|
flan-dev--socket)))
|
|
(_ (propertize " flan:off" 'face 'shadow
|
|
'help-echo "Not connected (C-c C-z)")))))
|
|
|
|
;; Appended rather than prepended: this is the least urgent thing in the line.
|
|
(add-to-list 'mode-line-misc-info '(:eval (flan-dev-mode-line)) t)
|
|
|
|
;;;###autoload
|
|
(defun flan-show-output ()
|
|
"Show the running program's output, after collecting anything pending."
|
|
(interactive)
|
|
(ignore-errors (flan-dev--request '(:op "describe")))
|
|
(display-buffer (get-buffer-create flan-dev-output-buffer)))
|
|
|
|
(defun flan-describe ()
|
|
"Report what the running program currently defines."
|
|
(interactive)
|
|
(let ((r (flan-dev--request '(:op "describe"))))
|
|
(message "flan dev: %s, %d functions, %d globals"
|
|
(if (plist-get r :alive) "running" "exited")
|
|
(length (plist-get r :fns)) (length (plist-get r :globals)))))
|
|
|
|
;;; Where an error is
|
|
|
|
;; A reply's :loc is "file:line:col", and the column is a *byte* offset into
|
|
;; the line: the reader walks the source a byte at a time (lib/reader.ml), and
|
|
;; OCaml strings are bytes. Emacs counts characters, so the same rule the
|
|
;; framing has applies here — one non-ASCII character earlier on the line puts
|
|
;; the marker as many columns to the right as that character has bytes. Going
|
|
;; through `byte-to-position' from the line's start is the whole fix, and
|
|
;; `forward-char' would also have walked into the next line on a column past
|
|
;; the end of a short one.
|
|
|
|
(defun flan-dev--parse-loc (loc)
|
|
"Split LOC, a \"file:line:col\" string, into (FILE LINE COL), or nil."
|
|
(when (and (stringp loc)
|
|
(string-match "\\`\\(.*\\):\\([0-9]+\\):\\([0-9]+\\)\\'" loc))
|
|
(list (match-string 1 loc)
|
|
(string-to-number (match-string 2 loc))
|
|
(string-to-number (match-string 3 loc)))))
|
|
|
|
(defun flan-dev--position (line col)
|
|
"Position of LINE and byte-column COL in the current buffer."
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(forward-line (1- line))
|
|
(let* ((bol (point))
|
|
(eol (line-end-position))
|
|
(want (+ (position-bytes bol) (max 0 (1- col))))
|
|
(p (and (<= want (position-bytes eol)) (byte-to-position want))))
|
|
;; Clamped rather than trusted: a column past the end of the line is a
|
|
;; location for something the reader wanted and did not find, and
|
|
;; overshooting into the next line would point at innocent code.
|
|
(min (or p eol) eol))))
|
|
|
|
(defun flan-dev--buffer-visiting (file)
|
|
"The live buffer visiting FILE, or nil.
|
|
Compared with `file-equal-p', so a symlinked or relative path still matches."
|
|
(seq-find (lambda (b)
|
|
(let ((n (buffer-local-value 'buffer-file-name b)))
|
|
(and n (file-exists-p file) (file-equal-p n file))))
|
|
(buffer-list)))
|
|
|
|
;;; Error overlays
|
|
|
|
;; An error is shown where it is rather than only in the echo area, because the
|
|
;; echo area is gone the moment you type and the location is the useful half of
|
|
;; the message. It is cleared when the next evaluation of that buffer is
|
|
;; accepted: an overlay left behind after a fix is a lie about the program, and
|
|
;; a stale one is worse than none.
|
|
|
|
(defface flan-dev-error-face
|
|
'((t :inherit error :underline (:style wave)))
|
|
"Face for the text an evaluation was rejected at."
|
|
:group 'flan-dev)
|
|
|
|
(defface flan-dev-error-message-face
|
|
'((t :inherit error :height 0.9))
|
|
"Face for the message shown beside a rejected form."
|
|
:group 'flan-dev)
|
|
|
|
(defun flan-dev-clear-errors (&optional buffer)
|
|
"Remove Flan error overlays from BUFFER, or from the current buffer."
|
|
(interactive)
|
|
(with-current-buffer (or buffer (current-buffer))
|
|
(remove-overlays (point-min) (point-max) 'flan-dev-error t)))
|
|
|
|
(defun flan-dev--show-error (loc msg)
|
|
"Mark MSG at LOC, if LOC names a file some buffer is visiting.
|
|
Returns non-nil when it put an overlay somewhere."
|
|
(let ((parts (flan-dev--parse-loc loc)))
|
|
(when parts
|
|
(let ((buf (flan-dev--buffer-visiting (nth 0 parts))))
|
|
(when buf
|
|
(with-current-buffer buf
|
|
(flan-dev-clear-errors buf)
|
|
(let* ((beg (flan-dev--position (nth 1 parts) (nth 2 parts)))
|
|
(end (save-excursion (goto-char beg) (line-end-position)))
|
|
(ov (make-overlay beg end buf t nil)))
|
|
(overlay-put ov 'flan-dev-error t)
|
|
(overlay-put ov 'face 'flan-dev-error-face)
|
|
(overlay-put ov 'help-echo msg)
|
|
(overlay-put ov 'evaporate nil)
|
|
(overlay-put ov 'priority 100)
|
|
(overlay-put ov 'after-string
|
|
(propertize (concat " " msg)
|
|
'face 'flan-dev-error-message-face))
|
|
;; Point goes there too, but only in the buffer being looked at:
|
|
;; moving point in a buffer nobody is showing is a surprise the
|
|
;; next time it is visited.
|
|
(when (eq buf (current-buffer)) (goto-char beg))
|
|
t)))))))
|
|
|
|
;;; Evaluating
|
|
|
|
(defun flan-dev--report (reply what)
|
|
"Report REPLY, describing WHAT was sent."
|
|
(if (equal (plist-get reply :status) "ok")
|
|
(let ((fns (plist-get reply :fns))
|
|
(names (plist-get reply :names))
|
|
(note (plist-get reply :note))
|
|
(value (plist-get reply :value)))
|
|
;; Accepted, so whatever the last rejection marked is no longer true.
|
|
(flan-dev-clear-errors)
|
|
(when flan-dev-echo-result
|
|
(if value
|
|
;; An expression's value, rendered inside the running program —
|
|
;; nothing was marshalled back, because nothing could be.
|
|
(message "=> %s" value)
|
|
(if note
|
|
;; The daemon accepted it and had nothing to send. Say so rather
|
|
;; than claiming an install that did not happen.
|
|
(message "%s: %s" (if names (string-join names ", ") what) note)
|
|
(message "%s installed in %.0fms"
|
|
(if fns (string-join fns ", ")
|
|
(if names (string-join names ", ") what))
|
|
(or (plist-get reply :ms) 0))))))
|
|
;; The daemon reports where, so mark it there. This must not itself
|
|
;; signal: the error the caller is owed is the daemon's, and losing it to a
|
|
;; bad location would report the wrong thing entirely.
|
|
(let ((loc (plist-get reply :loc))
|
|
(msg (plist-get reply :message)))
|
|
(ignore-errors (flan-dev--show-error loc (or msg "rejected")))
|
|
(user-error "flan: %s%s" (or msg "rejected")
|
|
(if loc (format " (%s)" loc) "")))))
|
|
|
|
(defun flan-dev--eval (code what)
|
|
"Send CODE to the running program. WHAT names it for the echo area."
|
|
(flan-dev--report
|
|
(flan-dev--request
|
|
;; buffer-file-name so an error points at the file being edited rather than
|
|
;; at the daemon's placeholder.
|
|
(list :op "eval" :code code :file (or buffer-file-name "<buffer>")))
|
|
what))
|
|
|
|
(defun flan-dev--text (start end)
|
|
"The buffer text from START to END, on the line it is actually written on.
|
|
|
|
The daemon reads what it is sent starting at line 1, so a form taken from the
|
|
middle of a buffer comes back with a location relative to the *snippet* — and
|
|
an error overlay drawn from that sits on line 1 of the file, pointing at
|
|
whatever happens to be there. Leading newlines are the whole fix: the reader
|
|
skips them, and the line numbers in the reply are then the buffer's own. The
|
|
columns already were, because a top-level form starts at column 1."
|
|
(concat (make-string (1- (line-number-at-pos start)) ?\n)
|
|
(buffer-substring-no-properties start end)))
|
|
|
|
(defun flan-dev--defun-bounds ()
|
|
"Bounds of the top-level form containing or preceding point, as (START . END)."
|
|
(save-excursion
|
|
(end-of-defun)
|
|
(let ((end (point)))
|
|
(beginning-of-defun)
|
|
(cons (point) end))))
|
|
|
|
(defun flan-dev--defun-at-point ()
|
|
"The text of the top-level form containing or preceding point."
|
|
(let ((b (flan-dev--defun-bounds)))
|
|
(buffer-substring-no-properties (car b) (cdr b))))
|
|
|
|
;;;###autoload
|
|
(defun flan-eval-defun ()
|
|
"Recompile the top-level form at point and install it in the running program."
|
|
(interactive)
|
|
(let ((b (flan-dev--defun-bounds)))
|
|
(flan-dev--eval (flan-dev--text (car b) (cdr b)) "form")))
|
|
|
|
;;;###autoload
|
|
(defun flan-eval-buffer ()
|
|
"Recompile every top-level form in this buffer and install them together.
|
|
One module, not one per form: a var and the function that uses it have to
|
|
arrive in the same load or the first refers to storage that does not exist."
|
|
(interactive)
|
|
(flan-dev--eval (buffer-substring-no-properties (point-min) (point-max))
|
|
(buffer-name)))
|
|
|
|
;;;###autoload
|
|
(defun flan-eval-last-sexp ()
|
|
"Evaluate the expression before point in the running program and show it."
|
|
(interactive)
|
|
(let ((code (buffer-substring-no-properties
|
|
(save-excursion (backward-sexp) (point))
|
|
(point))))
|
|
(flan-dev--report
|
|
(flan-dev--request
|
|
(list :op "eval-expr" :code code :file (or buffer-file-name "<buffer>")))
|
|
"expression")))
|
|
|
|
;;;###autoload
|
|
(defun flan-eval-region (start end)
|
|
"Recompile the top-level forms between START and END."
|
|
(interactive "r")
|
|
(flan-dev--eval (flan-dev--text start end) "region"))
|
|
|
|
(provide 'flan-dev)
|
|
;;; flan-dev.el ends here
|