diff --git a/NEXT.md b/NEXT.md index 7d6f7e2..345fe2b 100644 --- a/NEXT.md +++ b/NEXT.md @@ -759,9 +759,26 @@ can sit on the same `Session` later; it should not have gated the editor. (:op "describe") → (:status "ok" :fns (…) :globals (…) :alive t) (:op "eval" :code "…" :file "/buf.flan") → (:status "ok" :names (…) :fns (…) :ms 19.0) → (:status "error" :message "…" :loc "/buf.flan:1:19") +(:op "defs") → (:status "ok" :defs ((name kind signature loc) …)) (:op "close") ``` +`defs` is its own op rather than more fields on `describe`, because `describe` +is what an editor *polls* — it is how the program's output is drained — and +signatures on that would be paid for every time anyone glanced at the output +buffer. It is asked once on connect and again after each accepted install. +Four strings an editor reads with `read` and nothing else: eldoc, completion +and find-definition want the same three facts about a name. `loc` is empty +where there is none to give, because only `Tast.fn` carries one — an editor +must refuse rather than go looking for the definition itself, which in a +program of several files finds the wrong one. Parameter *names* are not in the +Tast, so a signature is `step [i64 f32] i64`: types only. + +The daemon makes its own source path absolute before building, because every +location it reports derives from it. `flan dev src/game.flan` run from a +project root otherwise answered `src/game.flan:12:7`, which an editor can only +resolve by guessing which directory it was relative to. + An evaluation that declares nothing to install — a declaration the program already has, with no body and no new storage — is accepted and answered with `:note "nothing to install"` rather than by shipping an empty module. Building @@ -809,6 +826,20 @@ of the protocol choice: `prin1` writes a request and `read` reads a reply. | `C-c C-o` | the running program's own output, in `*flan-output*` | | `C-c C-r` | a prompt on the running program (`*flan-repl*`) | | `C-c C-d` | what the running program currently defines | +| `M-.` / `M-,` | where a name is written, through an `xref` backend | + +eldoc, `completion-at-point` and `M-.` all read one cached `defs` reply rather +than asking per keystroke: eldoc fires on an idle timer and completion inside +redisplay, and neither may block on a socket or signal. The cache is refreshed +at the two moments the answer can have changed — on connect, and after an +evaluation the daemon accepted — so a `defn` just installed completes at once. + +The modeline says whether there is a program on the other end, in three states. +`lost` is a daemon that has gone away, which is ordinary rather than an error — +`flan dev` ends when its program does — so the next request reconnects on the +socket it was on. Strictly *before* a send, never after one: a connection that +died mid-request may have died after the daemon ran what it was given, and +resending would install it twice or evaluate a side-effecting expression twice. `C-c C-k` sends one module rather than a form at a time on purpose: a `defvar` and the function that uses it have to arrive in the same load, or the first @@ -823,8 +854,21 @@ daemon for this reason: it is not the same claim as the daemon answering correctly, and a mistake in the framing, in `beginning-of-defun` over Flan's syntax table, or in the reply reader passes `test_dev.ml` and fails here. -An error comes back with a location and the client moves point to it when it is -this buffer. +An error comes back with a location and the client draws an overlay there, with +the message beside the code, cleared the next time that buffer's evaluation is +accepted. Two things had to be right first. **The column in a `:loc` is a byte +offset**, because the reader walks the source a byte at a time — the same rule +as the framing, in a different place, and `forward-char` with it put the marker +as many columns right as the line had non-ASCII characters before it. 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 answered line 1 and every overlay would have sat on +the file's first line; the client pads the form with leading newlines, which +the reader skips, so the reply's line numbers are the buffer's own. + +An accepted evaluation says which names landed and what the build cost, and +flashes the region that was sent. Silent success is indistinguishable from +silent failure, and `beginning-of-defun` may well have found a different form +from the one point looked like it was in. **The program's stdout is a pipe into the daemon**, and whatever it printed since the last reply rides along with the next one into `*flan-output*`. Having diff --git a/emacs/flan-dev.el b/emacs/flan-dev.el index d5c8736..51e1289 100644 --- a/emacs/flan-dev.el +++ b/emacs/flan-dev.el @@ -23,6 +23,12 @@ ;;; Code: (require 'subr-x) +(require 'seq) +(require 'pcase) +(require 'pulse) +(require 'cl-lib) +(require 'xref) +(require 'eldoc) (defgroup flan-dev nil "Talking to a running Flan program." @@ -34,9 +40,15 @@ :type 'string) (defcustom flan-dev-echo-result t - "Whether a successful evaluation reports in the echo area." + "Whether an accepted evaluation reports in the echo area. +Turning this off makes a successful evaluation indistinguishable from one +that quietly did nothing, which is why it is on." :type 'boolean) +(defcustom flan-dev-names-shown 4 + "How many installed names to name before falling back to counting them." + :type 'integer) + (defcustom flan-dev-output-buffer "*flan-output*" "Buffer the running program's own output is appended to." :type 'string) @@ -72,7 +84,16 @@ (accept-process-output proc 0.05)) (goto-char (point-min)) (unless (re-search-forward "\\`\\([0-9]+\\)\n" nil t) - (error "flan dev: no reply")) + ;; 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) @@ -119,11 +140,59 @@ 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, 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'")) + "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) + ;; A restarted daemon is a rebuilt program: everything known + ;; about its names was about the last one. + (flan-dev--forget-defs) + ;; And asked again straight away. An empty cache is honest + ;; but silent: eldoc would go quiet and M-. would fall through + ;; to some other backend until the next install happened to + ;; refill it. Safe to call from here — the connection is live + ;; by now, so it does not come back through this function. + (ignore-errors (flan-dev-refresh-defs)) + (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 @@ -134,16 +203,9 @@ With no argument, look for `flan-dev-socket-name' up from this buffer." (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)) + (flan-dev--open socket) (let ((r (flan-dev--request '(:op "describe")))) + (flan-dev-refresh-defs) (message "flan dev: connected to %s (%d functions, %d globals)" (abbreviate-file-name socket) (length (plist-get r :fns)) (length (plist-get r :globals)))) @@ -156,8 +218,54 @@ With no argument, look for `flan-dev-socket-name' up from this buffer." (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) + (flan-dev--forget-defs) + (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)"))))) + +;; Installed buffer-locally by `flan-dev-setup', not globally. A global entry +;; would evaluate on every redisplay of every buffer in the session — dired, +;; eshell, everything — to return nil, for someone who may never open a .flan +;; file at all. The `derived-mode-p' guard above stays anyway: cheap, and it +;; keeps the function honest wherever it is called from. + ;;;###autoload (defun flan-show-output () "Show the running program's output, after collecting anything pending." @@ -173,8 +281,304 @@ With no argument, look for `flan-dev-socket-name' up from this buffer." (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))))))) + +;;; What the program defines + +;; eldoc, completion and find-definition all want the same three things about a +;; name — what it is, what it looks like, and where it was written — so the +;; daemon answers all three in one `defs' reply and this keeps the last one. +;; +;; It is a *cache* rather than a request per keystroke because of where these +;; are called from: eldoc fires on an idle timer and completion inside the +;; minibuffer's redisplay, and neither may block on a socket or signal. So +;; they read this and nothing else, and it is refreshed at the two moments the +;; answer can have changed — on connect, and after an evaluation the daemon +;; accepted. A freshly installed `defn' completes immediately; nothing else +;; can have appeared in between, because this editor is the only client. + +(defvar flan-dev--defs nil + "What the running program defines: a list of (NAME KIND SIGNATURE LOC). +LOC is the empty string where the daemon has none to give.") + +(defun flan-dev--forget-defs () + "Drop what is known about the program's names." + (setq flan-dev--defs nil)) + +(defun flan-dev-refresh-defs () + "Ask the running program what it defines, and remember it." + (interactive) + (setq flan-dev--defs (plist-get (flan-dev--request '(:op "defs")) :defs)) + (when (called-interactively-p 'interactive) + (message "flan: %d names" (length flan-dev--defs))) + flan-dev--defs) + +(defun flan-dev--lookup (name) + "The entry for NAME, or nil. + +A name is looked up exactly first. Failing that, a buffer inside a package +writes `settle' for what the program calls `sim/settle' — the alias is applied +from the file's own package, which this end does not know — so a name that is +the tail of exactly one program name resolves to it. Exactly one: several is +ambiguous and resolving it by picking would be a guess about which function +you meant." + (or (assoc name flan-dev--defs) + (let ((tail (concat "/" name))) + (let ((hits (seq-filter (lambda (d) (string-suffix-p tail (car d))) + flan-dev--defs))) + (and (= 1 (length hits)) (car hits)))))) + +(defun flan-dev--ambiguous (name) + "The entries whose name ends in NAME, when there is more than one." + (let ((hits (seq-filter (lambda (d) (string-suffix-p (concat "/" name) (car d))) + flan-dev--defs))) + (and (> (length hits) 1) hits))) + +;;; eldoc + +(defun flan-dev--enclosing-head () + "The symbol heading the innermost form point is inside, or nil." + (ignore-errors + (save-excursion + (let ((open (nth 1 (syntax-ppss)))) + (when open + (goto-char (1+ open)) + (and (looking-at "\\(?:\\sw\\|\\s_\\)+") (match-string-no-properties 0))))))) + +(defun flan-dev-eldoc-function (callback &rest _) + "Give CALLBACK the signature of the name at point, from the running program. +Falls back to the form point is inside, which is what you want while typing +its arguments. Reads the cache only: eldoc runs on a timer and must not +block on a socket or signal." + (let* ((name (or (thing-at-point 'symbol t) (flan-dev--enclosing-head))) + (d (and name (flan-dev--lookup name)))) + (when d + (funcall callback + (concat (propertize (nth 2 d) 'face 'font-lock-function-name-face) + (pcase (nth 1 d) + ("fn" "") + (k (concat " " k)))) + :thing (car d)) + t))) + +;;; Completion + +(defun flan-dev-completion-at-point () + "Complete the name at point against the running program's own names. +Nothing is offered when nothing is known — an empty table would look like +\"no such name\" rather than \"not connected\"." + (when flan-dev--defs + (let ((b (bounds-of-thing-at-point 'symbol))) + (when b + (list (car b) (cdr b) + (mapcar #'car flan-dev--defs) + :annotation-function + (lambda (n) (let ((d (assoc n flan-dev--defs))) + (and d (concat " " (nth 1 d))))) + :company-docsig + (lambda (n) (let ((d (assoc n flan-dev--defs))) (and d (nth 2 d)))) + ;; Not exclusive: dabbrev and the like still have something to + ;; say about a name the program has not been told about yet. + :exclusive 'no))))) + +;;; Finding a definition + +;; An xref backend rather than a command of its own, so M-. and M-, are what +;; they always are. Its refusals are by name: the daemon has no location for a +;; global, and the prelude is a string in the compiler rather than a file, and +;; both of those must say so instead of opening an empty buffer. + +(defun flan-dev-xref-backend () + "The xref backend for a buffer with a running Flan program behind it." + (and flan-dev--defs 'flan)) + +(cl-defmethod xref-backend-identifier-at-point ((_backend (eql flan))) + (thing-at-point 'symbol t)) + +(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql flan))) + (mapcar #'car flan-dev--defs)) + +(cl-defmethod xref-backend-definitions ((_backend (eql flan)) identifier) + (let ((d (flan-dev--lookup identifier))) + (cond + ((null d) + (if-let ((hits (flan-dev--ambiguous identifier))) + (user-error "flan: %s could be %s; write the one you mean" + identifier (string-join (mapcar #'car hits) " or ")) + (user-error "flan: the running program defines no %s" identifier))) + ((equal (nth 3 d) "") + ;; Tast.global and Tast.extern carry no Loc, so there is nothing to go + ;; to. Guessing by searching for "(defvar ticks" would find the wrong + ;; one in a program of several files, which is worse than refusing. + (user-error "flan: %s is a %s, and the daemon reports no location for one" + (car d) (nth 1 d))) + (t + (let ((parts (flan-dev--parse-loc (nth 3 d)))) + (cond + ((null parts) + (user-error "flan: the daemon gave %s an unreadable location: %s" + (car d) (nth 3 d))) + ((string-match-p "\\`<.*>\\'" (nth 0 parts)) + ;; The prelude is a string inside the compiler (lib/prelude.ml) and + ;; names itself ; anything in angle brackets is a + ;; placeholder the frontend made up, not a path. + (user-error "flan: %s is defined in %s, which is not a file on disk" + (car d) (nth 0 parts))) + ((not (file-name-absolute-p (nth 0 parts))) + ;; The daemon makes its own source path absolute, so anything + ;; relative arriving here came from somewhere that did not, and the + ;; directory it is relative to is the daemon's, not this one's. + (user-error "flan: %s is at %s, relative to a directory this end does not know" + (car d) (nth 0 parts))) + ((not (file-exists-p (nth 0 parts))) + ;; The prelude is a string inside the compiler (lib/prelude.ml), so + ;; its location names a file nobody can visit. + (user-error "flan: %s is defined in %s, which is not a file on disk" + (car d) (nth 0 parts))) + (t + (list (xref-make + (nth 2 d) + (xref-make-file-location + (nth 0 parts) (nth 1 parts) + ;; A byte column, like every other one the daemon sends, but + ;; a top-level definition starts at column 1 and anything + ;; indenting it is ASCII, so the two agree here. + (max 0 (1- (nth 2 parts))))))))))))) + +;;; Wiring it into a buffer + +(defun flan-dev-setup () + "Give this buffer eldoc, completion and M-. against the running program. +Installed from here rather than from `flan-mode', which must keep working for +someone editing Flan with no program running and this file never loaded." + (add-hook 'completion-at-point-functions #'flan-dev-completion-at-point nil t) + (add-hook 'xref-backend-functions #'flan-dev-xref-backend nil t) + ;; Registered, not switched on. Contributing a source is this file's + ;; business; whether eldoc runs at all is the user's, and turning it on for + ;; someone who has `global-eldoc-mode' off is overruling a decision they made + ;; on purpose. It is on by default, so this is what almost everyone gets. + (add-hook 'eldoc-documentation-functions #'flan-dev-eldoc-function nil t) + (unless (member '(:eval (flan-dev-mode-line)) mode-line-misc-info) + ;; Appended rather than prepended: the least urgent thing in the line. + (setq-local mode-line-misc-info + (append mode-line-misc-info '((:eval (flan-dev-mode-line))))))) + +(add-hook 'flan-mode-hook #'flan-dev-setup) + +;; Buffers that were already in flan-mode when this file loaded: the client is +;; autoloaded on first use, so by the time it arrives the file being edited has +;; long since had its mode hooks run. +(dolist (b (buffer-list)) + (with-current-buffer b + (when (derived-mode-p 'flan-mode) (flan-dev-setup)))) + ;;; Evaluating +;; An install that says nothing is indistinguishable from one that failed +;; silently, so every accepted evaluation reports what landed in the running +;; program and what it cost. The names come from the reply rather than from +;; what was typed: the daemon is the one that knows which of them it installed, +;; and a `defvar' the program already had is not among them. + +(defun flan-dev--names-phrase (names fallback) + "NAMES as a phrase for the echo area, or FALLBACK when there are none. +Long lists are counted and then sampled: an echo area truncated in the middle +of the tenth name tells you neither how many there were nor which." + (cond + ((null names) fallback) + ((<= (length names) flan-dev-names-shown) (string-join names ", ")) + (t (format "%d names (%s, …)" (length names) + (string-join (seq-take names flan-dev-names-shown) ", "))))) + (defun flan-dev--report (reply what) "Report REPLY, describing WHAT was sent." (if (equal (plist-get reply :status) "ok") @@ -182,54 +586,86 @@ With no argument, look for `flan-dev-socket-name' up from this buffer." (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) + ;; ...and a name that was just installed should complete, and have a + ;; signature, from this moment rather than from the next connect. + (when (or fns names) (ignore-errors (flan-dev-refresh-defs))) (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 put point there when it is this buffer. + (cond + ;; An expression's value, rendered inside the running program — + ;; nothing was marshalled back, because nothing could be. + (value (message "=> %s" value)) + ;; The daemon accepted it and had nothing to send. Say so rather + ;; than claiming an install that did not happen. + (note (message "flan: %s — %s" + (flan-dev--names-phrase names what) note)) + (t + ;; `:fns' are the bodies that were installed and `:names' is + ;; everything the evaluation declared; a buffer of five functions + ;; and two vars should not report as "five". + (message "flan: %s installed in %.0f ms%s" + (flan-dev--names-phrase fns what) + (or (plist-get reply :ms) 0) + (let ((vars (seq-difference names fns))) + (if vars (format " (also %s)" + (flan-dev--names-phrase vars "")) + ""))))))) + ;; 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))) - (when (and loc (string-match "\\`\\(.*\\):\\([0-9]+\\):\\([0-9]+\\)\\'" loc)) - (let ((file (match-string 1 loc)) - (line (string-to-number (match-string 2 loc))) - (col (string-to-number (match-string 3 loc)))) - (when (and buffer-file-name (file-equal-p file buffer-file-name)) - (goto-char (point-min)) - (forward-line (1- line)) - (forward-char (max 0 (1- col)))))) - (user-error "flan: %s" (or msg "rejected"))))) + (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." +(defun flan-dev--eval (code what &optional start end) + "Send CODE to the running program. WHAT names it for the echo area. +START and END, when given, are the region it came from, flashed on success." (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 ""))) - what)) + what) + ;; `flan-dev--report' signals on a rejection, so reaching here means it + ;; landed. Flashing the text that was sent answers "which form did that + ;; take?" — the question the echo area cannot, because point may be nowhere + ;; near the defn `beginning-of-defun' actually found. + (when (and start end) (pulse-momentary-highlight-region start end))) -(defun flan-dev--defun-at-point () - "The text of the top-level form containing or preceding point." +(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) - (buffer-substring-no-properties (point) end)))) + (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) - (flan-dev--eval (flan-dev--defun-at-point) "form")) + (let ((b (flan-dev--defun-bounds))) + (flan-dev--eval (flan-dev--text (car b) (cdr b)) "form" (car b) (cdr b)))) ;;;###autoload (defun flan-eval-buffer () @@ -256,7 +692,7 @@ arrive in the same load or the first refers to storage that does not exist." (defun flan-eval-region (start end) "Recompile the top-level forms between START and END." (interactive "r") - (flan-dev--eval (buffer-substring-no-properties start end) "region")) + (flan-dev--eval (flan-dev--text start end) "region" start end)) (provide 'flan-dev) ;;; flan-dev.el ends here diff --git a/emacs/flan-repl.el b/emacs/flan-repl.el index 340c09b..f66256a 100644 --- a/emacs/flan-repl.el +++ b/emacs/flan-repl.el @@ -56,6 +56,10 @@ (setq-local comint-input-sender #'flan-repl--send) ;; Nothing is echoed back by a process, because there is no process. (setq-local comint-process-echoes nil) + ;; The prompt gets completion, eldoc and M-. for the same names a buffer + ;; does, and against the same program: they read the client's cache, which + ;; is program-scoped, which is exactly what a prompt is. + (flan-dev-setup) (setq-local font-lock-defaults '(flan-font-lock-keywords))) (defun flan-repl--complete-p (text) diff --git a/emacs/test-flan-dev.el b/emacs/test-flan-dev.el index ab9dce3..116f208 100644 --- a/emacs/test-flan-dev.el +++ b/emacs/test-flan-dev.el @@ -16,6 +16,18 @@ (defvar test-flan--failures 0) +(defmacro test-flan--said (&rest body) + "Run BODY and return the last thing it put in the echo area. +`current-message' is nil under --batch, so the echo area is watched where it +is written instead — the real `message' call the real command makes." + `(let* ((said nil) + (probe (lambda (fmt &rest args) + (when fmt (setq said (apply #'format fmt args)))))) + (advice-add 'message :before probe) + (unwind-protect (progn ,@body) + (advice-remove 'message probe)) + said)) + (defun test-flan--check (name ok) (if ok (message " ok %s" name) (setq test-flan--failures (1+ test-flan--failures)) @@ -31,8 +43,55 @@ (setq buffer-read-only nil) (test-flan--check "flan-mode is on for a .flan file" (eq major-mode 'flan-mode)) + (test-flan--check "the modeline says so before connecting" + (and (eq (flan-dev-state) 'off) + (string-match-p "off" (flan-dev-mode-line)))) + (flan-connect socket) (test-flan--check "connected" (process-live-p flan-dev--connection)) + (test-flan--check "the modeline says a program is there" + (and (eq (flan-dev-state) 'live) + (string-match-p "live" (flan-dev-mode-line)))) + (test-flan--check "and says nothing in a buffer that is not Flan's" + (with-temp-buffer (null (flan-dev-mode-line)))) + ;; Buffer-locally, so that someone who loads this and never opens a .flan + ;; file is not evaluating it on every redisplay of every buffer they have. + (test-flan--check "the indicator is in this buffer's modeline" + (member '(:eval (flan-dev-mode-line)) mode-line-misc-info)) + (test-flan--check "and not in everyone else's" + (with-temp-buffer + (not (member '(:eval (flan-dev-mode-line)) + mode-line-misc-info)))) + + ;; A daemon restarted while Emacs was not looking is the ordinary case. The + ;; socket outlives this connection, so dropping the process and asking again + ;; is the same situation the client meets after a restart, and it must come + ;; back rather than fail. + (delete-process flan-dev--connection) + (test-flan--check "a dead connection reads as lost, not as never-connected" + (and (eq (flan-dev-state) 'lost) + (string-match-p "lost" (flan-dev-mode-line)))) + (let ((r (flan-dev--request '(:op "describe")))) + (test-flan--check "the next request reconnects on its own" + (and (process-live-p flan-dev--connection) + (member "step" (plist-get r :fns))))) + ;; ...and knows the program's names again. An empty cache after a reconnect + ;; is honest but silent: eldoc goes quiet and M-. falls through to another + ;; backend, with nothing said about why. + (test-flan--check "and knows the program's names again" + (assoc "step" flan-dev--defs)) + + ;; But a socket nobody is listening on is refused by name, rather than + ;; retried forever or reported as some other failure. + (let ((flan-dev--connection nil) + (flan-dev--socket "/nonexistent/flan-dev-not-here.sock") + (raised nil)) + (condition-case err (flan-dev--request '(:op "describe")) + (error (setq raised (error-message-string err)))) + (test-flan--check "a socket that is gone is refused by name" + (and raised + (string-match-p "flan-dev-not-here.sock" raised) + (string-match-p "nothing is listening" raised)))) (let ((r (flan-dev--request '(:op "describe")))) (test-flan--check "describe lists the program's functions" @@ -63,6 +122,190 @@ (test-flan--check "a form that does not check is reported" (and raised (string-match-p "unknown name" raised)))) + ;; The :loc column is a *byte* offset — lib/reader.ml walks the source a byte + ;; at a time — and Emacs counts characters. Same rule as the framing, a + ;; different place to get it wrong, and it shows up only for someone whose + ;; comments or identifiers are not ASCII. + (with-temp-buffer + (insert ";; héllo\n(defn wörld [] i64 nonsense)\n") + (let ((want (save-excursion + (goto-char (point-min)) + (search-forward "nonsense") + (match-beginning 0))) + (eol (save-excursion (goto-char (point-min)) (line-end-position)))) + (test-flan--check "a byte column lands on the right character" + (= (flan-dev--position + 2 (1+ (string-bytes "(defn wörld [] i64 "))) + want)) + (test-flan--check "a column past the end of a line is clamped to it" + (= (flan-dev--position 1 500) eol)))) + + ;; A rejected form is marked where it is, not only in the echo area. The + ;; daemon numbers lines from the start of what it was sent, so a form taken + ;; from the middle of a buffer only lands on the right line because the + ;; client pads it back into place before sending. + (goto-char (point-min)) + (search-forward "(defn step") + (goto-char (match-beginning 0)) + (let ((defn-line (line-number-at-pos))) + (save-excursion + (search-forward "(+ ticks 41)") + (replace-match "(+ ticks nonsense)")) + (ignore-errors (flan-eval-defun)) + (let ((ovs (seq-filter (lambda (o) (overlay-get o 'flan-dev-error)) + (overlays-in (point-min) (point-max))))) + (test-flan--check "a rejected form gets exactly one error overlay" + (= 1 (length ovs))) + (test-flan--check "the overlay is at the form, not at line 1" + (and ovs (>= (line-number-at-pos (overlay-start (car ovs))) + defn-line))) + (test-flan--check "the overlay carries the daemon's reason" + (and ovs + (string-match-p + "unknown name" + (or (overlay-get (car ovs) 'help-echo) "")))) + (test-flan--check "and shows it beside the code" + (and ovs + (string-match-p + "unknown name" + (or (overlay-get (car ovs) 'after-string) ""))))) + ;; ...and it goes away when the next evaluation is accepted. A marker left + ;; behind after a fix is a lie about the running program. Point moved to + ;; the error, which is the point of all this, so start the search over. + (goto-char (point-min)) + (search-forward "(+ ticks nonsense)") + (replace-match "(+ ticks 41)") + (search-backward "(defn step") + ;; A silent success is indistinguishable from a silent failure, so an + ;; accepted evaluation says what landed in the running program and what it + ;; cost. The name comes from the *reply*: the daemon is the one that knows + ;; which names it installed. + (let ((said (test-flan--said (flan-eval-defun)))) + (test-flan--check "an accepted evaluation clears it" + (null (seq-filter (lambda (o) (overlay-get o 'flan-dev-error)) + (overlays-in (point-min) (point-max))))) + (test-flan--check "and says which name landed" + (and said (string-match-p "\\_" said))) + (test-flan--check "and how long it took" + (and said (string-match-p "[0-9]+ ms" said))))) + + ;; A declaration the program already has installs nothing, and must say so + ;; rather than reporting a time for a build that did not happen. + (let ((said (test-flan--said + (flan-dev--eval "(defvar ticks i64)" "form")))) + (test-flan--check "an evaluation with nothing to install says so" + (and said (string-match-p "nothing to install" said) + (not (string-match-p "installed" said))))) + + ;; Many names are counted and sampled. An echo area truncated in the middle + ;; of the tenth name says neither how many there were nor which. + (test-flan--check "a long list of names is counted, not cut off" + (equal (flan-dev--names-phrase + '("a" "b" "c" "d" "e" "f") "fallback") + "6 names (a, b, c, d, …)")) + (test-flan--check "a short one is just named" + (equal (flan-dev--names-phrase '("a" "b") "fallback") "a, b")) + + ;; `defs' is what eldoc, completion and M-. all read. One op answering all + ;; three, cached, because eldoc fires on an idle timer and completion inside + ;; redisplay, and neither may block on a socket. + (test-flan--check "the program's names are known" + (assoc "step" flan-dev--defs)) + (test-flan--check "with a signature" + (equal (nth 2 (assoc "step" flan-dev--defs)) "step [] i64")) + (test-flan--check "a global is known, and says it is one" + (equal (nth 1 (assoc "ticks" flan-dev--defs)) "var")) + (test-flan--check "so is an imported package's extern" + (let ((d (assoc "agent/wait-raw" flan-dev--defs))) + (and d (equal (nth 1 d) "extern")))) + ;; `step' was last installed from this buffer, so that is where the daemon + ;; says it is — which is also the check that the client's line padding put it + ;; on the line it is really on rather than on line 1. + (test-flan--check "a fn carries where it is written" + (equal (nth 3 (assoc "step" flan-dev--defs)) + (format "%s:%d:7" buffer-file-name + (save-excursion + (goto-char (point-min)) + (search-forward "(defn step") + (line-number-at-pos))))) + + ;; eldoc: the signature of the name at point, and of the form point is + ;; inside, which is what you want while typing arguments. + (goto-char (point-min)) + (search-forward "(set ticks (step") + (let ((said nil)) + (test-flan--check "eldoc answers for the name at point" + (and (flan-dev-eldoc-function + (lambda (s &rest _) (setq said s))) + said (string-match-p "step \\[\\] i64" said)))) + (let ((said nil)) + (save-excursion + (goto-char (point-min)) + (search-forward "(set ticks (step)") + (backward-char 1) ; inside (step ...), not on the name + (flan-dev-eldoc-function (lambda (s &rest _) (setq said s)))) + (test-flan--check "and for the form point is inside" + (and said (string-match-p "step" said)))) + (let ((said nil)) + (with-temp-buffer + (insert "not-a-flan-name") + (flan-dev-eldoc-function (lambda (s &rest _) (setq said s)))) + (test-flan--check "and says nothing about a name the program has not got" + (null said))) + + ;; Completion: the running program's names, through `completion-at-point'. + (goto-char (point-min)) + (search-forward "(defn step") + (let* ((capf (flan-dev-completion-at-point)) + (table (nth 2 capf))) + (test-flan--check "completion offers the program's own names" + (member "step" (all-completions "ste" table))) + (test-flan--check "and the names an import brought in" + (member "agent/wait" (all-completions "agent/" table))) + (test-flan--check "and annotates each with what it is" + (equal (funcall (plist-get (nthcdr 3 capf) + :annotation-function) + "ticks") + " var"))) + + ;; M-. through xref, so it is the key it always is. + (let ((xs (xref-backend-definitions 'flan "step")) + (line (save-excursion (goto-char (point-min)) + (search-forward "(defn step") + (line-number-at-pos)))) + (test-flan--check "M-. finds where a function is written" + (and (= 1 (length xs)) + (let ((l (xref-item-location (car xs)))) + (and (file-equal-p (xref-location-group l) + buffer-file-name) + (= (xref-location-line l) line)))))) + + ;; And the two things it cannot do, refused by name with the reason rather + ;; than by opening an empty buffer. + (let ((raised nil)) + (condition-case err (xref-backend-definitions 'flan "ticks") + (user-error (setq raised (error-message-string err)))) + (test-flan--check "M-. on a global refuses, saying why" + (and raised (string-match-p "ticks" raised) + (string-match-p "no location" raised)))) + (let ((raised nil)) + (condition-case err (xref-backend-definitions 'flan "print-line") + (user-error (setq raised (error-message-string err)))) + (test-flan--check "M-. into the prelude refuses, saying why" + (and raised (string-match-p "prelude" raised) + (string-match-p "not a file on disk" raised)))) + (let ((raised nil)) + (condition-case err (xref-backend-definitions 'flan "no-such-name") + (user-error (setq raised (error-message-string err)))) + (test-flan--check "and so does a name the program does not have" + (and raised (string-match-p "no no-such-name" raised)))) + + ;; A name installed now must complete now, not after the next connect. + (flan-dev--eval "(defn freshly-added [] i64 7)" "form") + (test-flan--check "a name just installed is known immediately" + (equal (nth 2 (assoc "freshly-added" flan-dev--defs)) + "freshly-added [] i64")) + ;; The session is not poisoned by that: a good form still lands. (flan-dev--eval "(defn step [] i64 (set ticks (+ ticks 100)) ticks)" "form") diff --git a/lib/dev.ml b/lib/dev.ml index b6ec136..7243853 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -236,6 +236,64 @@ let describe t = t.session.Session.program.Tast.globals); ":alive " ^ (if alive t then "t" else "nil") ] +(* [describe] answers what exists; this answers what each one *is*. Its own op + rather than more fields on [describe], because [describe] is polled — an + editor uses it to drain the program's output — and this is asked once on + connect and again after each install. Putting signatures on the poll would + pay for them every time anyone looked at the output buffer. + + One entry per name: (name kind signature loc). Four strings, so the editor + reads it with [read] and nothing here needs a new wire type. [loc] is empty + where there is none to give — only [Tast.fn] carries one — and an editor + that finds it empty must say so rather than guess a file. + + Parameter *names* are not in the Tast, so a signature shows types only. *) +let signature_of_fn (f : Tast.fn) = + Printf.sprintf "%s [%s] %s" f.Tast.name + (String.concat " " (List.map Types.to_string f.Tast.params)) + (Types.to_string f.Tast.ret) + +let entry ~name ~kind ~sign ~loc = + Wire.list [ Wire.quote name; Wire.quote kind; Wire.quote sign; Wire.quote loc ] + +let defs t = + let p = t.session.Session.program in + let fns = + List.filter_map + (fun (f : Tast.fn) -> + match f.Tast.fparent with + (* A handler-bind clause the checker lifted out. Nobody wrote this + name, so completing it is noise and jumping to it is meaningless. *) + | Some _ -> None + | None -> + Some + (entry ~name:f.Tast.name ~kind:"fn" ~sign:(signature_of_fn f) + ~loc:(Loc.to_string f.Tast.floc))) + p.Tast.fns + in + let globals = + List.map + (fun (g : Tast.global) -> + entry ~name:g.Tast.gname + ~kind:(if g.Tast.gconst then "const" else "var") + ~sign: + (Printf.sprintf "%s %s" g.Tast.gname (Types.to_string g.Tast.gty)) + ~loc:"") + p.Tast.globals + in + let externs = + List.map + (fun (e : Tast.extern) -> + entry ~name:e.Tast.ename ~kind:"extern" + ~sign: + (Printf.sprintf "%s [%s] %s" e.Tast.ename + (String.concat " " (List.map Types.to_string e.Tast.eparams)) + (Types.to_string e.Tast.eret)) + ~loc:"") + p.Tast.externs + in + ok [ ":defs " ^ Wire.list (fns @ globals @ externs) ] + let handle t req = match Wire.string_field req "op" with | Some "eval" -> @@ -255,6 +313,7 @@ let handle t req = eval_expr t ~code ~origin | None -> error "eval-expr needs :code") | Some "describe" -> describe t + | Some "defs" -> defs t | Some "close" -> ok [] | Some op -> error ("unknown op: " ^ op) | None -> error "no :op" @@ -286,6 +345,12 @@ let serve t fd = let start ~file ~sock = let t0 = Unix.gettimeofday () in + (* Absolute, because every location this daemon ever reports is derived from + it and an editor is not in this process's working directory. [flan dev + src/game.flan] run from a project root would otherwise send back + "src/game.flan:12:7", which the editor can only resolve by guessing which + directory it was relative to. *) + let file = try Unix.realpath file with Unix.Unix_error _ -> file in let session, l = Session.create ~file in let dir = Filename.concat (Filename.get_temp_dir_name ()) diff --git a/test/test_dev.ml b/test/test_dev.ml index 2376343..0b07b3e 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -86,6 +86,46 @@ let () = let r = request c "(:op \"describe\")" in if status r <> "ok" then fail "describe: %s" (status r); + (* [defs] is its own op rather than more fields on [describe], because + [describe] is what an editor polls to drain the program's output. It + carries what eldoc, completion and find-definition each need: a kind, + a signature, and where the name is written where that is knowable. + An empty location is the honest answer for a global — Tast.global has + no Loc — and an editor is expected to refuse rather than guess. *) + let r = request c "(:op \"defs\")" in + if status r <> "ok" then fail "defs: %s" (status r); + (match Wire.field r "defs" with + | Some { Form.v = Form.List entries; _ } -> + let find name = + List.find_map + (fun (e : Form.t) -> + match e.Form.v with + | Form.List + ({ Form.v = Form.Str n; _ } + :: { Form.v = Form.Str kind; _ } + :: { Form.v = Form.Str sign; _ } + :: { Form.v = Form.Str loc; _ } :: []) + when String.equal n name -> Some (kind, sign, loc) + | _ -> None) + entries + in + (match find "step" with + | Some ("fn", "step [] i64", loc) when String.length loc > 0 -> + (* Absolute, because an editor is not in this process's working + directory and cannot resolve a relative one. *) + if loc.[0] <> '/' then fail "a fn's location is relative: %s" loc + | Some (k, s, l) -> fail "step is described as (%s, %s, %s)" k s l + | None -> fail "defs did not mention step"); + (match find "ticks" with + | Some ("var", "ticks i64", "") -> () + | Some (k, s, l) -> fail "ticks is described as (%s, %s, %s)" k s l + | None -> fail "defs did not mention ticks"); + (match find "agent/wait-raw" with + | Some ("extern", _, _) -> () + | Some (k, _, _) -> fail "an extern is described as %s" k + | None -> fail "defs did not mention an imported extern") + | _ -> fail "defs did not answer with a list"); + (* A form that does not check comes back as an error with a location, and must not disturb the session. *) let r = request c "(:op \"eval\" :code \"(defn step [] i64 nonsense)\" :file \"/tmp/buf.flan\")" in