7118d6106d
All three want the same three facts 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 the client keeps the last one. `defs` is its own op rather than more fields on `describe`. `describe` is what an editor *polls*: it is how the program's output gets drained, and the existing tests ask it in loops. Signatures riding on that would be paid for every time anyone glanced at the output buffer. This is asked once on connect and again after each accepted install, which is exactly when the answer can have changed — so a `defn` typed a second ago completes. 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 redisplay, and neither may block on a socket or signal. Three refusals rather than three guesses. A global has no location because `Tast.global` carries no `Loc`, and searching the buffer for "(defvar ticks" instead would find the wrong one in a program of several files. The prelude is a string inside the compiler, so its location names a file nobody can visit. A short name that could be several of the program's package-qualified ones is ambiguous, and picking would be a guess about which function you meant — a name that is the tail of exactly *one* is not a guess, and resolves. Functions the checker invented — a lifted handler-bind clause, which carries an `fparent` — are left out entirely: nobody wrote that name, so completing it is noise and jumping to it is meaningless. And the daemon now makes its own source path absolute before building, because every location it reports derives from it. `flan dev src/game.flan` from a project root answered `src/game.flan:12:7`, which an editor can only resolve by guessing what it was relative to. lib/dev.ml is the only compiler file touched: a `defs` op, its three list builders, and the one `realpath` in `start`. Nothing existing changed shape — `describe`, `eval` and `eval-expr` answer byte for byte what they did.
683 lines
30 KiB
EmacsLisp
683 lines
30 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)
|
|
(require 'pulse)
|
|
(require 'cl-lib)
|
|
(require 'xref)
|
|
(require 'eldoc)
|
|
|
|
(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 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)
|
|
|
|
(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)
|
|
;; A restarted daemon is a rebuilt program: everything known
|
|
;; about its names was about the last one.
|
|
(flan-dev--forget-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
|
|
(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"))))
|
|
(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))))
|
|
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)
|
|
(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)")))))
|
|
|
|
;; 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)))))))
|
|
|
|
;;; 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 <prelude>; 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)
|
|
(add-hook 'eldoc-documentation-functions #'flan-dev-eldoc-function nil t)
|
|
(eldoc-mode 1))
|
|
|
|
(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")
|
|
(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)
|
|
;; ...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
|
|
(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)))
|
|
(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 &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 "<buffer>")))
|
|
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--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" (car b) (cdr b))))
|
|
|
|
;;;###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" start end))
|
|
|
|
(provide 'flan-dev)
|
|
;;; flan-dev.el ends here
|