aab6c28450
An error that only reaches the echo area is gone the moment you type, and the location was the useful half of it. So the client draws an overlay at the `:loc` the daemon sent, with the message beside the code, and clears it the next time that buffer's evaluation is accepted — a marker left behind after a fix is a lie about the running program. Two things had to be right first, and neither was. The column in a `:loc` is a *byte* offset: lib/reader.ml walks the source a byte at a time and OCaml strings are bytes. The old code did `forward-char` with it, which is the same mistake as counting a frame's length in characters, in a different place — one accented character earlier on the line puts the marker as many columns to the right. It goes through `byte-to-position` from the line's start now, and is clamped to the end of the line, which the old code also needed: a column past a short line walked into the next one and pointed at innocent code. And the daemon numbers lines from the start of what it was *sent*, so `C-c C-c` on a defn halfway down a buffer came back saying line 1. Every overlay would have sat on the file's first line. The fix is leading newlines: the reader skips them, and the reply's line numbers are then the buffer's own. No protocol change, and nothing the daemon has to know. Marking the error 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.
371 lines
16 KiB
EmacsLisp
371 lines
16 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)
|
|
|
|
(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)
|
|
(error "flan dev: no reply"))
|
|
(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--live-connection ()
|
|
"The open connection, or signal an error saying how to get one."
|
|
(unless (and flan-dev--connection
|
|
(process-live-p flan-dev--connection))
|
|
(error "Not connected: M-x flan-connect, or start `flan dev program.flan'"))
|
|
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))
|
|
(when (process-live-p flan-dev--connection)
|
|
(delete-process flan-dev--connection))
|
|
(let ((buf (get-buffer-create " *flan-dev*")))
|
|
(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))
|
|
(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)
|
|
(message "flan dev: disconnected"))
|
|
|
|
;;;###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
|