2717 lines
134 KiB
EmacsLisp
2717 lines
134 KiB
EmacsLisp
;;; flan.el --- Talk to a running Flan program -*- lexical-binding: t; -*-
|
|
|
|
;; Author: Joseph Ferano <joseph@ferano.io>
|
|
;; Version: 0.1.0
|
|
;; Package-Requires: ((emacs "29.1"))
|
|
;; Keywords: languages, lisp, tools
|
|
|
|
;; The headers above are what make this directory installable. M-x
|
|
;; package-install-file on it reads them, and a file with no Version: is not a
|
|
;; package as far as package.el is concerned -- until now the client was
|
|
;; reachable only by adding it to load-path by hand, which is a thing to
|
|
;; explain to every person who wants to try it.
|
|
;;
|
|
;; 29.1 is the floor because it is the oldest Emacs any of this has been run
|
|
;; against, not because some function here is known to need it. dape, which
|
|
;; flan-dape drives, asks for 29.1 as well and is a soft dependency: it is
|
|
;; reached through declare-function, so the rest of the client loads and works
|
|
;; without it and it is deliberately not listed above. The compiler this talks
|
|
;; to is not an Emacs package and cannot be listed here either -- emacs/MANUAL.md
|
|
;; says what has to be on PATH.
|
|
|
|
;; 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. M-x flan starts that
|
|
;; daemon from here and connects when it is serving, so the loop needs no
|
|
;; terminal — and M-x flan-quit ends it, which ends the program, because
|
|
;; the daemon is what owns the program's lifetime.
|
|
;;
|
|
;; 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-c C-M-x runs the program's `main' again without rebuilding anything. A
|
|
;; program that finishes no longer ends its process: the main thread parks,
|
|
;; holding the compiler, the session and every global the run left, so closing
|
|
;; a window costs nothing and getting another one is one key. Nothing is
|
|
;; reset between runs — it is what calling (main) at a Common Lisp or Clojure
|
|
;; prompt does, and the modeline says `flan:parked' while it waits.
|
|
;;
|
|
;; C-x C-e evaluates the form before point *in the running program*. An
|
|
;; expression is a different primitive from redefining a name: there is
|
|
;; nothing to install a body into, so it is wrapped in a thunk the program
|
|
;; runs at its next frame boundary, and its value is shown. 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.
|
|
;;
|
|
;; A *declaration* before point takes the other path and is installed, the way
|
|
;; C-c C-c installs one. The key is dispatched on the form it would send, so
|
|
;; a `defvar' at the top of a file evaluates as a declaration while an
|
|
;; expression inside a `defn' body still evaluates as an expression. The
|
|
;; split used to be by keybinding, which meant a top-level `defvar' under
|
|
;; C-x C-e came back as "defvar is a top-level declaration, not an
|
|
;; expression" — an editor artifact, not a limit of the compiler, which has
|
|
;; had both evaluators all along.
|
|
|
|
;;; Code:
|
|
|
|
(require 'subr-x)
|
|
(require 'seq)
|
|
(require 'pcase)
|
|
(require 'pulse)
|
|
(require 'cl-lib)
|
|
(require 'xref)
|
|
(require 'eldoc)
|
|
;; The macroexpansion buffer is a `flan-mode' buffer — what is in it is Flan
|
|
;; source and reading it is the point — so the mode has to exist by the time
|
|
;; this file defines one derived from it. Not a cycle: flan-mode.el autoloads
|
|
;; the commands here and requires nothing back.
|
|
(require 'flan-mode)
|
|
|
|
(defgroup flan nil
|
|
"Talking to a running Flan program."
|
|
:group 'flan
|
|
:prefix "flan-")
|
|
|
|
(defcustom flan-socket-name ".flan-dev.sock"
|
|
"Name of the socket `flan dev' listens on, looked for up from the buffer."
|
|
:type 'string)
|
|
|
|
(defcustom flan-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-inline-result t
|
|
"Whether an expression's value is shown beside the form it came from.
|
|
|
|
The two knobs are not two ways of saying one thing. This one is about a
|
|
*value*: nothing else an evaluation produces has a place in the buffer to sit
|
|
beside, so an install still reports through `flan-echo-result' whatever this
|
|
is set to. Where they do overlap — an expression whose value could go either
|
|
place — the overlay wins and the echo is not also written, because saying the
|
|
same number twice is how a reader learns to stop reading both. The echo is
|
|
what happens when no overlay could be drawn: the REPL, a value that came back
|
|
with no region behind it, or this turned off."
|
|
:type 'boolean)
|
|
|
|
(defcustom flan-names-shown 4
|
|
"How many installed names to name before falling back to counting them."
|
|
:type 'integer)
|
|
|
|
(defcustom flan-output-buffer "*flan-output*"
|
|
"Buffer the running program's own output is appended to."
|
|
:type 'string)
|
|
|
|
(defcustom flan-daemon-buffer "*flan-dev*"
|
|
"Buffer the daemon's own output goes to.
|
|
This is where a build that failed says so: the daemon compiles the program
|
|
before it binds its socket, so a program that does not compile produces no
|
|
socket at all and this buffer is the only account of why. It is also where a
|
|
build that is merely slow can be watched, which is what the reply timeout
|
|
below points at."
|
|
:type 'string)
|
|
|
|
(defcustom flan-reply-timeout 30
|
|
"Seconds to wait for one reply from the daemon before giving up.
|
|
|
|
This bounds a single request, not a session. Thirty seconds is generous
|
|
for an evaluation and tight for a first compile of a large program on a
|
|
cold object cache, which is the one case that legitimately runs long — so
|
|
it is a setting rather than a constant.
|
|
|
|
Giving up here never resends. If the daemon took the request and died
|
|
before replying the evaluation may well already have happened, and sending
|
|
it again would install a body twice or run a side-effecting expression
|
|
twice; reconnecting happens before a send and never after one."
|
|
:type 'number)
|
|
|
|
(defvar flan--connection nil
|
|
"The open connection, or nil.")
|
|
|
|
(defvar flan--socket nil
|
|
"Path of the socket `flan--connection' is connected to.")
|
|
|
|
(defvar flan--stopped nil
|
|
"Name of the condition the program is stopped on, or nil if it is running.
|
|
Set from every reply the daemon sends, which is how a stop that nothing
|
|
asked about is noticed at all.")
|
|
|
|
(defvar flan--parked nil
|
|
"Non-nil when the program has finished and its process is waiting to re-run.
|
|
Set from every reply, as `flan--stopped' is and for the same reason: a
|
|
program finishes without announcing it, and the commonest way to finish is
|
|
closing its window with the mouse. Nothing about the session has gone —
|
|
`flan-rerun' runs `main' again, with the globals as the last run left them.")
|
|
|
|
;; The daemon this Emacs started, which is not the same thing as the
|
|
;; connection and must not be confused with one: `flan-connect' attaches to a
|
|
;; program running in a terminal, and from that moment the two name different
|
|
;; sessions. Kept up here with the rest of the client's state rather than
|
|
;; beside the code that starts a daemon, because `flan-connect' reads them
|
|
;; before it replaces anything.
|
|
(defvar flan--file nil
|
|
"The program the daemon this Emacs started was started on, or nil.
|
|
Kept so that it can be started again on the same program and the same
|
|
socket, which is what `flan-restart-program' is.")
|
|
|
|
(defvar flan--daemon nil
|
|
"The `flan dev' process this Emacs started, or nil.
|
|
A daemon started in a terminal is not here, and `flan-connect' still works
|
|
for it — this is only what Emacs is responsible for killing.")
|
|
|
|
(defvar flan--daemon-socket nil
|
|
"Path of the socket the daemon this Emacs started is listening on, or nil.
|
|
|
|
`flan--socket' is where the *connection* is, and the two part company the
|
|
moment `flan-connect' attaches to something else: a second program in another
|
|
terminal is an ordinary thing to go and look at, and it does not stop this
|
|
Emacs being responsible for the daemon it launched. Keeping both is what lets
|
|
`flan-quit' tell one session from two.")
|
|
|
|
(defvar flan--busy nil
|
|
"Non-nil while a request is waiting for its reply.
|
|
`flan--read-reply' runs `accept-process-output', which runs timers, so
|
|
without this the poll timer could fire inside another request and read the
|
|
reply that request was waiting for.")
|
|
|
|
;;; 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--bare (form)
|
|
"FORM with every string stripped of its text properties.
|
|
A propertized string prints as #(...) syntax, which the daemon's reader
|
|
takes as a bare symbol followed by a stray list — the field silently stops
|
|
being a string. Buffer text arrives propertized (the REPL's comint input
|
|
does, for one), so the wire layer strips rather than trusting every caller
|
|
to."
|
|
(cond ((stringp form) (substring-no-properties form))
|
|
((consp form) (cons (flan--bare (car form))
|
|
(flan--bare (cdr form))))
|
|
(t form)))
|
|
|
|
(defun flan--send (proc form)
|
|
"Send FORM to PROC as one framed message."
|
|
(let* ((payload (encode-coding-string (prin1-to-string (flan--bare form))
|
|
'utf-8 t)))
|
|
(process-send-string proc (format "%d\n%s" (length payload) payload))))
|
|
|
|
(defun flan--take-reply (proc)
|
|
"Read one complete framed message out of PROC's buffer, or return nil.
|
|
|
|
Never waits. This is the half of `flan--read-reply' that does not block,
|
|
split out for the watch timer: a timer that called `accept-process-output'
|
|
would stall the UI every tick, which is exactly the mistake the Clojure
|
|
original left a comment about. See `flan-watch--tick'."
|
|
(when (buffer-live-p (process-buffer proc))
|
|
(with-current-buffer (process-buffer proc)
|
|
(goto-char (point-min))
|
|
(when (re-search-forward "\\`\\([0-9]+\\)\n" nil t)
|
|
(let* ((n (string-to-number (match-string 1)))
|
|
(body-start (point)))
|
|
;; Present in full, or not yet — a partial body is not an error here,
|
|
;; it is the ordinary state between the send and the reply.
|
|
(when (>= (- (position-bytes (point-max)) (position-bytes body-start)) n)
|
|
(flan--extract-reply body-start n)))))))
|
|
|
|
(defun flan--extract-reply (body-start n)
|
|
"Read the N bytes at BODY-START as a reply and delete the frame.
|
|
Point is in the process buffer, and the frame is known to be complete.
|
|
|
|
The frame is deleted *before* it is read, which is the whole of the ordering
|
|
and the only reason this is worth a comment. A payload that will not read is
|
|
a bug at the other end, and the client's job is to report it once: reading
|
|
first would leave those bytes at the head of the buffer, so the next request
|
|
would read the same unreadable frame again, and every request after that —
|
|
one bad reply and the connection is wedged until Emacs is restarted.
|
|
Consuming it first costs the reply, which was lost anyway, and leaves the
|
|
stream in step for the request that follows."
|
|
(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)))
|
|
(delete-region (point-min) end)
|
|
(car (read-from-string text))))
|
|
|
|
(defun flan--no-reply (proc)
|
|
"Signal that PROC has not answered, saying which of the two silences it is.
|
|
|
|
Deliberately not retried, in either case. 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)
|
|
;; What a person does next, not just what failed. A live daemon that
|
|
;; has not answered is nearly always still working — a first compile of
|
|
;; a large program on a cold object cache is the case that runs long —
|
|
;; and the daemon's own log says which step it is on, so the message
|
|
;; names the buffer to look in and the setting to raise rather than
|
|
;; leaving both to be discovered.
|
|
(error "flan dev: no reply in %ss from %s; the daemon may still be building — see %s for its log, and raise `flan-reply-timeout' if this build is simply long"
|
|
flan-reply-timeout
|
|
(abbreviate-file-name (or flan--socket "the daemon"))
|
|
flan-daemon-buffer)
|
|
(error
|
|
"flan dev: the daemon on %s closed the connection; not resent, because it may already have run"
|
|
(abbreviate-file-name (or flan--socket "?")))))
|
|
|
|
(defun flan--read-reply (proc)
|
|
"Block until PROC sends one complete framed message, and read it."
|
|
(with-current-buffer (process-buffer proc)
|
|
(let ((deadline (+ (float-time) flan-reply-timeout)))
|
|
;; 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))
|
|
;; Nothing is erased here, and that is the difference between the two
|
|
;; deadlines. A header that has not arrived in full is a valid prefix
|
|
;; of a reply still on its way — throwing it away would turn a daemon
|
|
;; that is merely slow into a stream out of step by however much of the
|
|
;; count had landed.
|
|
(unless (re-search-forward "\\`\\([0-9]+\\)\n" nil t)
|
|
(flan--no-reply proc))
|
|
(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))
|
|
(if (>= (- (position-bytes (point-max)) (position-bytes body-start)) n)
|
|
(flan--extract-reply body-start n)
|
|
;; The body never came, so the count at the head of the buffer is a
|
|
;; promise about bytes that will never be made good: reading on from
|
|
;; here would take the *next* reply's header as this one's payload
|
|
;; and every request after it would be answered by the one before.
|
|
;; The frame is dead — drop it, and the connection is in step again
|
|
;; for whatever a person does next. Testing the condition again
|
|
;; rather than trusting the loop is the whole fix: falling through
|
|
;; to `flan--extract-reply' with a short buffer signals a
|
|
;; wrong-type error from `byte-to-position', which says nothing
|
|
;; about a timeout to whoever reads it.
|
|
(erase-buffer)
|
|
(flan--no-reply proc))))))
|
|
|
|
(defun flan--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-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)))))))
|
|
|
|
;; The break buffer, which this file shows but does not draw. An autoload
|
|
;; rather than a `require': flan-cnr.el reaches the daemon through this file,
|
|
;; so requiring it here would be a cycle, and it is wanted only at the moment
|
|
;; a program stops.
|
|
(autoload 'flan-cnr-show "flan-cnr" nil t)
|
|
|
|
;;; Opening the break buffer when the program stops
|
|
|
|
;; The mode line and one echo-area line were the whole of it: the buffer that
|
|
;; says what happened and what can be done about it appeared only when `C-c
|
|
;; C-b' was typed. `flan--absorb' below already knows the moment — it
|
|
;; reads `:stopped' off every reply, and the poll covers the case where no
|
|
;; reply is coming — so this is a hook at a point that exists rather than new
|
|
;; plumbing.
|
|
;;
|
|
;; Three things had to be settled to build it, and they are settled here.
|
|
;;
|
|
;; **It displays, it does not select.** A program stops on its own clock, not
|
|
;; the editor's: the likeliest moment is in a frame of its own game loop while
|
|
;; someone is typing in another buffer. Taking the window would send the next
|
|
;; keystrokes somewhere they were not aimed, and `q' in a break buffer is not
|
|
;; what a half-typed word wanted to be. So `display-buffer': the buffer
|
|
;; appears, point does not move, and the window that had focus keeps it.
|
|
;; `flan-break-on-stop' can be set to `focus' by anyone who disagrees, and
|
|
;; to nil to go back to the mode line alone.
|
|
;;
|
|
;; **`(pause)' is not a special case.** It was worth asking — a breakpoint is
|
|
;; deliberate where an error is not, so it could be argued it has earned the
|
|
;; window. It has not, and for the reason above: `(pause)' is deliberate at
|
|
;; the moment it was *written*, and the frame it fires on still arrives
|
|
;; whenever the program gets there. Nothing about that is more expected than
|
|
;; an error, from the point of view of the hands on the keyboard. What it does
|
|
;; get is an honest headline — `Pause' is a stop and not a failure, and the
|
|
;; break buffer says so rather than calling it unhandled.
|
|
;;
|
|
;; **A stop that arrives mid-edit disturbs nothing**, which falls out of
|
|
;; displaying rather than selecting. Two guards go beyond that. Nothing
|
|
;; happens while the minibuffer is active, because a prompt is a modal thing
|
|
;; someone is in the middle of and rearranging windows under it is hostile;
|
|
;; and nothing happens while a keyboard macro is running, because a macro that
|
|
;; behaves differently depending on whether the program happened to stop is a
|
|
;; macro that cannot be trusted. In both cases the mode line still says
|
|
;; stopped and `C-c C-b' still works, so nothing is lost but the automatic
|
|
;; part.
|
|
|
|
(defcustom flan-break-on-stop 'display
|
|
"What to do when the program stops.
|
|
`display' shows the break buffer without taking focus, `focus' shows it and
|
|
selects its window, and nil leaves it to the mode line and `C-c C-b'."
|
|
:type '(choice (const :tag "Show it" display)
|
|
(const :tag "Show it and go there" focus)
|
|
(const :tag "Only the mode line" nil)))
|
|
|
|
(defun flan--auto-break ()
|
|
"Show the break buffer, if the program is still stopped and it is safe to.
|
|
Runs from a timer, deliberately: `flan--absorb' notices the stop in the
|
|
middle of reading a reply on the socket, with `flan--busy' bound, and
|
|
`flan-cnr-show' asks the daemon three more questions. Issuing those from
|
|
inside the read they were triggered by would interleave two conversations on
|
|
one connection.
|
|
|
|
The check is on the state rather than on the edge that scheduled this. By the
|
|
time this runs the edge has been consumed, `flan-cnr-show''s own `break' has
|
|
been through `flan--absorb' again, and the program may have been resumed in
|
|
between — so what matters is whether it is stopped *now*."
|
|
(when (and flan--stopped
|
|
flan-break-on-stop
|
|
(not flan--busy)
|
|
(process-live-p flan--connection)
|
|
;; Someone is in the middle of answering a prompt.
|
|
(not (active-minibuffer-window))
|
|
;; A macro must do the same thing every time it is run.
|
|
(not (or executing-kbd-macro defining-kbd-macro)))
|
|
;; Errors are swallowed on purpose. This is a timer nobody asked to run,
|
|
;; and a daemon that refuses it has already said so through the mode line;
|
|
;; signalling here would put an error in the echo area in place of the
|
|
;; message naming the condition, which is the more useful of the two.
|
|
(ignore-errors
|
|
(save-selected-window
|
|
(let ((buf (flan-cnr-show)))
|
|
(when (and (eq flan-break-on-stop 'focus) (buffer-live-p buf))
|
|
(let ((win (get-buffer-window buf)))
|
|
(when win (select-window win)))))))))
|
|
|
|
(defun flan--absorb (reply)
|
|
"Take from REPLY the two things every reply carries, and return it.
|
|
The program's output, and whether it is stopped. Both are read here rather
|
|
than at each call site because `flan--report' signals on a rejection —
|
|
state attached to a reply that turns out to be an error would be thrown away
|
|
with it, and a rejected evaluation is a likely moment to *become* stopped."
|
|
(flan--append-output (plist-get reply :output))
|
|
;; The same edge treatment `flan--stopped' gets below, and the message is
|
|
;; the reason: a program that finished is a program somebody is about to want
|
|
;; back, and the name of the command that does it is the whole of what they
|
|
;; need. Once, on the edge — the poll runs every second, and a line in the
|
|
;; echo area every second is a line nobody reads.
|
|
(let ((was flan--parked)
|
|
(now (and (plist-get reply :parked) t)))
|
|
(setq flan--parked now)
|
|
(unless (eq was now)
|
|
(force-mode-line-update t)
|
|
(when now
|
|
(message "flan: the program finished; C-c C-M-x runs it again"))))
|
|
(let ((was flan--stopped)
|
|
(now (and (plist-get reply :stopped)
|
|
(or (plist-get reply :condition) "a condition"))))
|
|
(setq flan--stopped now)
|
|
(unless (equal was now)
|
|
(force-mode-line-update t)
|
|
;; Once, on the edge. A message every poll would bury whatever else the
|
|
;; echo area was saying, every second, for as long as the program sat
|
|
;; there.
|
|
(when now
|
|
(message "flan: stopped on %s — C-c C-b to choose a restart" now)
|
|
;; On the edge, and out of band. See `flan--auto-break' for why
|
|
;; it cannot happen here: this runs inside the read of a reply on the
|
|
;; socket, and showing the buffer asks three more questions down it.
|
|
(run-at-time 0 nil #'flan--auto-break))))
|
|
reply)
|
|
|
|
(defvar flan-settle-hook nil
|
|
"Run before anything is sent, against the connection as it stands.
|
|
|
|
The protocol is one reply per request on one connection, and that is the whole
|
|
reason this exists. Anything that sends without waiting — the watch timer is
|
|
the only such thing — leaves a reply in flight that the *next* request would
|
|
otherwise read as its own. So a sender-in-flight hangs a function here that
|
|
collects its own reply first, and the invariant holds: exactly one request
|
|
outstanding, and every reply consumed by whoever asked for it.
|
|
|
|
Before the connection is checked, not after, and that ordering is the point.
|
|
An outstanding reply belongs to the connection it was asked on; if the daemon
|
|
has been restarted under Emacs, that connection is gone and no reply is coming
|
|
on the new one. Running this first is what lets a hook see that for itself
|
|
and drop its pending flag, rather than sitting out a full
|
|
`flan-reply-timeout' waiting on a socket the question was never asked
|
|
down.")
|
|
|
|
(defun flan--request (form)
|
|
"Send FORM to the connected program and return its reply."
|
|
;; `flan--busy' first of all, and around the reconnect as well as around
|
|
;; the send: `flan--live-connection' asks the new daemon what it
|
|
;; defines, and `accept-process-output' runs timers, so a poll firing in the
|
|
;; middle of that would be a second conversation on the connection this one
|
|
;; just opened.
|
|
(let ((flan--busy t))
|
|
(run-hooks 'flan-settle-hook)
|
|
(let ((proc (flan--live-connection)))
|
|
(flan--absorb (progn (flan--send proc form)
|
|
(flan--read-reply proc))))))
|
|
|
|
;;; Noticing that the program stopped
|
|
|
|
;; A program can stop at any moment — that is the point of the break loop — and
|
|
;; nothing in a request/response protocol will say so unless something asks.
|
|
;; Both halves of the answer are here, and they are for two different moments:
|
|
;;
|
|
;; the state rides on every reply, because the likeliest instant for a
|
|
;; program to stop is the one just after an evaluation, and that is a reply
|
|
;; the client is already reading. Finding out a second later, from a poll,
|
|
;; would be finding out after the echo area had already said the evaluation
|
|
;; was fine;
|
|
;;
|
|
;; and a timer, because a program that stops while nobody is evaluating
|
|
;; anything — the ordinary way, in a frame of its own game loop — produces no
|
|
;; reply at all, and folding state into replies that never come says nothing.
|
|
;;
|
|
;; The timer does not reconnect. `flan--request' reopens a socket the
|
|
;; daemon restarted under it, which is right for something a person did and
|
|
;; wrong for a background timer: it would quietly erase the `lost' state that
|
|
;; exists to be seen. So the timer sends on the live process or does nothing.
|
|
|
|
(defcustom flan-poll-interval 1.0
|
|
"Seconds between background checks of whether the program has stopped.
|
|
Set to nil to leave the program's state to whatever replies happen to say."
|
|
:type '(choice number (const :tag "Never" nil)))
|
|
|
|
(defvar flan--timer nil
|
|
"The background poll, or nil.")
|
|
|
|
(defun flan--poll ()
|
|
"Ask the daemon how the program is, if it is safe to ask right now."
|
|
(when (and (not flan--busy)
|
|
(process-live-p flan--connection))
|
|
(let ((proc flan--connection)
|
|
(flan--busy t))
|
|
(ignore-errors
|
|
;; The same settle every other sender does, and for the same reason.
|
|
;; `flan--busy' is not enough on its own: the watch timer leaves a
|
|
;; request in flight and *clears* nothing, deliberately — it binds no
|
|
;; busy flag, because it never waits — so a poll that checked only the
|
|
;; flag would send `describe' with the watch's reply still coming and
|
|
;; read that instead. The two would then stay swapped for the rest of
|
|
;; the session, each consumer answering the other's question, which is
|
|
;; exactly the interleaving `flan-settle-hook' exists to prevent.
|
|
(run-hooks 'flan-settle-hook)
|
|
;; `describe' rather than `break': it is the cheap op, it is what
|
|
;; drains the program's output, and the state is on every reply anyway.
|
|
;; Asking `break' would fetch restart names nobody is choosing from.
|
|
(flan--send proc '(:op "describe"))
|
|
(flan--absorb (flan--read-reply proc))))))
|
|
|
|
(defun flan--start-polling ()
|
|
"Begin watching for the program stopping."
|
|
(flan--stop-polling)
|
|
(when flan-poll-interval
|
|
(setq flan--timer
|
|
(run-with-timer flan-poll-interval flan-poll-interval
|
|
#'flan--poll))))
|
|
|
|
(defun flan--stop-polling ()
|
|
"Stop watching."
|
|
(when flan--timer (cancel-timer flan--timer))
|
|
(setq flan--timer nil))
|
|
|
|
;;; Connection
|
|
|
|
(defun flan--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-socket-name)))
|
|
(and dir (expand-file-name flan-socket-name dir))))
|
|
|
|
(defun flan--open (socket)
|
|
"Open a connection to SOCKET and make it the current one."
|
|
(when (process-live-p flan--connection)
|
|
(delete-process flan--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--connection
|
|
(make-network-process
|
|
:name "flan" :buffer buf :family 'local :service socket
|
|
:coding 'binary :noquery t))
|
|
(setq flan--socket socket))
|
|
(setq flan--stopped nil)
|
|
(setq flan--parked nil)
|
|
(flan--start-polling)
|
|
(force-mode-line-update t)
|
|
flan--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--live-connection ()
|
|
"The open connection, reconnecting if the daemon has been restarted."
|
|
(unless (process-live-p flan--connection)
|
|
(cond
|
|
((null flan--socket)
|
|
(error "Not connected: M-x flan to start a program, or M-x flan-connect"))
|
|
((not (file-exists-p flan--socket))
|
|
(setq flan--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--socket)))
|
|
(t
|
|
(condition-case err
|
|
(progn (flan--open flan--socket)
|
|
;; A restarted daemon is a rebuilt program: everything known
|
|
;; about its names was about the last one.
|
|
(flan--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-refresh-defs))
|
|
(message "flan dev: reconnected to %s"
|
|
(abbreviate-file-name flan--socket)))
|
|
(error
|
|
(setq flan--connection nil)
|
|
(force-mode-line-update t)
|
|
;; A refusal on a path that exists is a socket file outliving the
|
|
;; process that bound it -- a daemon killed outright rather than one
|
|
;; that ended. `flan dev' removes its own socket on every way out it
|
|
;; controls, so reaching here means it was killed, and the raw
|
|
;; "Connection refused" is the least useful thing that could be said
|
|
;; about that: it reads as a daemon that is there and declining. Two
|
|
;; investigations in this repository have started from that reading
|
|
;; and gone the wrong way.
|
|
(if (string-match-p "[Cc]onnection refused" (error-message-string err))
|
|
(error "flan dev: %s is a leftover socket -- whatever bound it is \
|
|
gone; remove it and start `flan dev program.flan' again"
|
|
(abbreviate-file-name flan--socket))
|
|
(error "flan dev: cannot reconnect to %s: %s"
|
|
(abbreviate-file-name flan--socket)
|
|
(error-message-string err))))))))
|
|
flan--connection)
|
|
|
|
;;;###autoload
|
|
(defun flan-connect (&optional socket)
|
|
"Connect to a `flan dev' daemon listening on SOCKET.
|
|
With no argument, look for `flan-socket-name' up from this buffer."
|
|
(interactive
|
|
(list (or (flan--find-socket)
|
|
(read-file-name "flan dev socket: "))))
|
|
(unless socket (user-error "No %s found above this buffer" flan-socket-name))
|
|
(setq socket (expand-file-name socket))
|
|
;; Attaching to a second program is a thing people do on purpose — a daemon
|
|
;; running in a terminal is exactly what this command is for — but it leaves
|
|
;; two sessions where the client can only name one, and until it was said
|
|
;; out loud the cost fell on `flan-quit': "stop the daemon this Emacs
|
|
;; started" ended up closing whatever the connection happened to be pointing
|
|
;; at *and* killing the daemon, which by then were two different programs.
|
|
;; Naming both is most of the fix, because the situation is fine once it is
|
|
;; known about; the refusal for a Lisp caller matches `flan''s, where a
|
|
;; running program is never discarded without someone saying so.
|
|
(when (and (process-live-p flan--daemon)
|
|
flan--daemon-socket
|
|
(not (equal socket flan--daemon-socket)))
|
|
(let ((mine (abbreviate-file-name (or flan--file flan--daemon-socket)))
|
|
(theirs (abbreviate-file-name socket)))
|
|
(if (called-interactively-p 'interactive)
|
|
(unless (y-or-n-p
|
|
(format "%s is running here; connect to %s and leave it? "
|
|
mine theirs))
|
|
(user-error "flan dev: staying with %s" mine))
|
|
(user-error
|
|
"flan dev: %s is running from this Emacs; M-x flan-connect interactively to attach to %s as well"
|
|
mine theirs))))
|
|
(flan--open socket)
|
|
(let ((r (flan--request '(:op "describe"))))
|
|
(flan-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--connection)
|
|
|
|
(defun flan-disconnect ()
|
|
"Close the connection, which also ends the daemon and its program."
|
|
(interactive)
|
|
(when (process-live-p flan--connection)
|
|
(ignore-errors (flan--request '(:op "close")))
|
|
(delete-process flan--connection))
|
|
(setq flan--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--socket nil)
|
|
(setq flan--stopped nil)
|
|
(flan--stop-polling)
|
|
(flan--forget-defs)
|
|
(force-mode-line-update t)
|
|
(message "flan dev: disconnected"))
|
|
|
|
;;; Starting the daemon
|
|
|
|
;; Before this, a dev loop began in a terminal: `flan dev program.flan' in one
|
|
;; window and Emacs in another, with the socket found by walking up from the
|
|
;; buffer. That is one window too many for something an editor can own — and
|
|
;; it is the daemon that owns the program's lifetime, so the terminal was also
|
|
;; the only place a program could be stopped from.
|
|
;;
|
|
;; Waiting for the socket *file* is what this deliberately does not do. The
|
|
;; daemon unlinks a stale socket before binding, so a file left behind by a
|
|
;; crashed run exists before the new daemon has bound anything: waiting for it
|
|
;; to appear either succeeds instantly against nothing or races the unlink.
|
|
;; Connecting is the only test that means what it says, so it is retried until
|
|
;; it works, until the timeout, or until the daemon exits — whichever comes
|
|
;; first.
|
|
|
|
(defcustom flan-command "flan"
|
|
"The Flan compiler, as `flan dev' is started from Emacs.
|
|
A name is looked up on `exec-path'; a path is used as given."
|
|
:type 'string)
|
|
|
|
(defcustom flan-daemon-args nil
|
|
"Extra arguments for `flan dev', after the file and before `-s'.
|
|
A list of strings, each one argument: (\"--llvm\") to compile the session
|
|
with LLVM instead of the x86 dev backend, (\"--debug\") for a session
|
|
`flan-dape' can set breakpoints in.
|
|
|
|
These belong to the daemon, not to the program it runs."
|
|
:type '(repeat string))
|
|
|
|
;; `flan-daemon-buffer' belongs to this section and is declared with the
|
|
;; other buffer names at the top of the file instead, because the reply reader
|
|
;; -- which runs long before any of this -- names it in the message it gives
|
|
;; when a request times out, and the byte-compiler reads a file in order.
|
|
|
|
(defcustom flan-start-timeout 60
|
|
"Seconds to wait for a daemon started from Emacs to accept a connection.
|
|
It builds the program first, which for a cold project is most of this."
|
|
:type 'number)
|
|
|
|
;; The three variables that say what this Emacs started — `flan--file',
|
|
;; `flan--daemon' and `flan--daemon-socket' — are declared with the
|
|
;; rest of the client's state at the top of the file for the same reason:
|
|
;; `flan-connect' reads all three before it replaces a connection, and the
|
|
;; byte-compiler reads a file in order.
|
|
|
|
(defun flan--daemon-sentinel (proc event)
|
|
"Say that the daemon PROC has gone, once, when it does. EVENT says how."
|
|
(unless (process-live-p proc)
|
|
(when (eq proc flan--daemon)
|
|
(setq flan--daemon nil)
|
|
(setq flan--daemon-socket nil)
|
|
(force-mode-line-update t)
|
|
;; Named, because the daemon exits for two very different reasons — the
|
|
;; program finished, or it never built — and the buffer is where the
|
|
;; difference is written.
|
|
(message "flan dev: the daemon exited (%s); see %s"
|
|
(string-trim (or event "")) flan-daemon-buffer))))
|
|
|
|
(defun flan--start-daemon (file socket)
|
|
"Start `flan dev' on FILE listening on SOCKET, and return the process."
|
|
(let* ((buf (get-buffer-create flan-daemon-buffer))
|
|
;; Expanded before `default-directory' moves, so that a command given
|
|
;; as a path is the path the user meant and not one relative to the
|
|
;; program's directory. A bare name is left alone for `exec-path'.
|
|
(cmd (if (file-name-directory flan-command)
|
|
(expand-file-name flan-command)
|
|
flan-command))
|
|
;; `flan-daemon-args' goes after the file and before `-s', which is
|
|
;; where the usage line puts the flags and where `flan dev' reads
|
|
;; them from: everything but the path and the socket pair is a flag,
|
|
;; wherever it sits. Built once and used twice, because the buffer's
|
|
;; first line is what somebody reads to find out what ran and it used
|
|
;; to reassemble the command rather than show it — two spellings that
|
|
;; could disagree, and with anything else on the line they would have.
|
|
(args (append (list cmd "dev" file)
|
|
flan-daemon-args
|
|
(list "-s" socket)))
|
|
;; The daemon runs where the program is, and so does the program it
|
|
;; launches — it inherits this. A game opening "assets/tiles.png"
|
|
;; means the project's directory, not whichever buffer Emacs happened
|
|
;; to be in when the command was typed. (Imports do not depend on
|
|
;; this: lib/load.ml resolves those from the importing file.)
|
|
(default-directory (file-name-directory (expand-file-name file))))
|
|
(with-current-buffer buf
|
|
(let ((inhibit-read-only t))
|
|
(erase-buffer)
|
|
(insert (mapconcat #'identity args " ") "\n\n"))
|
|
(setq default-directory (file-name-directory (expand-file-name file))))
|
|
(make-process
|
|
:name "flan-daemon" :buffer buf
|
|
:command args
|
|
;; The daemon writes its ready line and the program's stderr to stderr,
|
|
;; and both belong in the same buffer in the order they happened.
|
|
:connection-type 'pipe :noquery t
|
|
:sentinel #'flan--daemon-sentinel)))
|
|
|
|
(defun flan--connect-when-ready (socket proc)
|
|
"Connect to SOCKET once PROC is serving it, or say why that never happened."
|
|
(let ((deadline (+ (float-time) flan-start-timeout))
|
|
(done nil))
|
|
(while (not done)
|
|
(cond
|
|
((condition-case nil (progn (flan--open socket) t) (error nil))
|
|
(setq done t))
|
|
((not (process-live-p proc))
|
|
;; The likeliest failure by far: the program did not compile, so the
|
|
;; daemon died before binding. The reason is in its buffer and not in
|
|
;; anything this end can see — so show the buffer rather than name it
|
|
;; and leave someone to go and find it.
|
|
(display-buffer flan-daemon-buffer)
|
|
(user-error "flan dev: the daemon exited before it was ready; see %s"
|
|
flan-daemon-buffer))
|
|
((> (float-time) deadline)
|
|
(display-buffer flan-daemon-buffer)
|
|
(user-error "flan dev: no socket on %s after %ss; see %s"
|
|
(abbreviate-file-name socket) flan-start-timeout
|
|
flan-daemon-buffer))
|
|
(t (accept-process-output proc 0.05))))))
|
|
|
|
;;;###autoload
|
|
(defun flan (file &optional socket)
|
|
"Start `flan dev' on FILE and connect to it when it is ready.
|
|
SOCKET defaults to `flan-socket-name' beside FILE, which is where the
|
|
daemon puts it when it is not told otherwise.
|
|
|
|
Interactively, a buffer visiting a .flan file is started without asking; from
|
|
anywhere else, and under a prefix argument, the file is read from the
|
|
minibuffer.
|
|
|
|
When called interactively while a daemon this Emacs started is alive, asks
|
|
before stopping it and switching programs. A noninteractive call still
|
|
refuses: callers cannot silently discard a running program's state."
|
|
(interactive
|
|
;; Starting a program is about the buffer the command was called from.
|
|
;; Keeping [flan--file] as DEFAULT here made a previous project win over the
|
|
;; current buffer: after working on sand.flan, invoking this from
|
|
;; ~/Development/gameboy/gameboy.flan still proposed (and could start)
|
|
;; sand.flan. [flan-restart-program] is the deliberate way to restart the
|
|
;; previous program; an ordinary M-x command must not do that.
|
|
;;
|
|
;; A buffer already visiting a .flan file has answered the question, so it is
|
|
;; taken rather than offered: the prompt had nothing to add but a keystroke
|
|
;; and a chance to get it wrong. The prefix argument is how you say the
|
|
;; buffer is not what you meant — and it still only changes what is asked,
|
|
;; never which file the unasked case picks.
|
|
(let ((file (and buffer-file-name
|
|
(string-suffix-p ".flan" buffer-file-name)
|
|
(expand-file-name buffer-file-name))))
|
|
(list (if (and file (not current-prefix-arg))
|
|
file
|
|
(read-file-name "flan dev: "
|
|
(and file (file-name-directory file))
|
|
file t
|
|
(and file (file-name-nondirectory file)))))))
|
|
(when (process-live-p flan--daemon)
|
|
;; `interactive' has already read FILE. Refusing only here used to make
|
|
;; that selection look as though it had been ignored: the old daemon kept
|
|
;; running, even though the minibuffer had just accepted a different
|
|
;; program. Keep the state-preserving default for Lisp callers, but let a
|
|
;; person explicitly choose to replace their own session.
|
|
(if (called-interactively-p 'interactive)
|
|
(if (y-or-n-p
|
|
(format "Stop %s and start %s? "
|
|
(abbreviate-file-name
|
|
(or flan--file "the running program"))
|
|
(abbreviate-file-name (expand-file-name file))))
|
|
(flan-quit)
|
|
(user-error "flan dev: keeping %s"
|
|
(abbreviate-file-name
|
|
(or flan--file "the running program"))))
|
|
(user-error "flan dev: already running on %s; M-x flan-quit first"
|
|
(abbreviate-file-name (or flan--socket "a socket")))))
|
|
(let* ((file (expand-file-name file))
|
|
(socket (or socket
|
|
(expand-file-name flan-socket-name
|
|
(file-name-directory file)))))
|
|
(unless (file-exists-p file)
|
|
(user-error "flan dev: no such file: %s" file))
|
|
(setq flan--file file)
|
|
(setq flan--daemon-socket socket)
|
|
(setq flan--daemon (flan--start-daemon file socket))
|
|
(flan--connect-when-ready socket flan--daemon)
|
|
;; Connected by now, so the rest is what `flan-connect' does after opening:
|
|
;; learn what the program defines, and say what is on the other end.
|
|
(let ((r (flan--request '(:op "describe"))))
|
|
(flan-refresh-defs)
|
|
(message "flan dev: %s running (%d functions, %d globals)"
|
|
(file-name-nondirectory file)
|
|
(length (plist-get r :fns)) (length (plist-get r :globals))))
|
|
flan--daemon))
|
|
|
|
;;;###autoload
|
|
(defun flan-quit ()
|
|
"Stop the daemon this Emacs started, and the program with it.
|
|
`close' first, which is the daemon's own way out and lets it unlink its
|
|
socket; the process is killed only if it does not take it.
|
|
|
|
One session at a time, which is the whole of the guard at the top. The
|
|
connection and the daemon are usually the same program and were treated as
|
|
though they always were: `close' went down whichever connection was current
|
|
and the daemon was killed afterwards, so a `flan-connect' to a second program
|
|
in another terminal turned one command into the end of two sessions — one of
|
|
them belonging to somebody else's window. When the connection is not the
|
|
daemon's, this closes the connection and says what it left running."
|
|
(interactive)
|
|
(if (and (process-live-p flan--daemon)
|
|
(process-live-p flan--connection)
|
|
flan--socket flan--daemon-socket
|
|
(not (equal flan--socket flan--daemon-socket)))
|
|
(let ((theirs (abbreviate-file-name flan--socket))
|
|
(mine (abbreviate-file-name
|
|
(or flan--file flan--daemon-socket))))
|
|
;; `flan-disconnect' is exactly the right half: it closes, which the
|
|
;; daemon on the other end takes as the end of its session, and it
|
|
;; touches nothing this Emacs started.
|
|
(flan-disconnect)
|
|
(message
|
|
"flan dev: closed %s; %s is still running here — M-x flan-quit again to stop it"
|
|
theirs mine))
|
|
(unless (process-live-p flan--daemon)
|
|
;; A daemon started in a terminal is not this Emacs' to kill, and
|
|
;; `flan-disconnect' is the thing that ends one of those — it closes, which
|
|
;; the daemon takes as the end of the session. Saying so is better than
|
|
;; doing the same thing under a name that claims more than it did.
|
|
(user-error "flan dev: no daemon started from Emacs%s"
|
|
(if (process-live-p flan--connection)
|
|
"; M-x flan-disconnect ends the one you are connected to"
|
|
"")))
|
|
(let ((proc flan--daemon))
|
|
(when (process-live-p flan--connection)
|
|
(ignore-errors (flan--request '(:op "close")))
|
|
(delete-process flan--connection))
|
|
(setq flan--connection nil
|
|
flan--socket nil
|
|
flan--stopped nil)
|
|
(flan--stop-polling)
|
|
(flan--forget-defs)
|
|
(when (process-live-p proc)
|
|
;; It has been told; give it a moment to go on its own before killing
|
|
;; it, so that it unlinks its socket and reaps its child itself.
|
|
(let ((deadline (+ (float-time) 2)))
|
|
(while (and (process-live-p proc) (< (float-time) deadline))
|
|
(accept-process-output proc 0.05)))
|
|
(when (process-live-p proc)
|
|
;; Killed rather than asked, so its own cleanup never runs — and that
|
|
;; cleanup is what signals the program. The program is therefore
|
|
;; probably still running, reparented, holding its agent socket, and
|
|
;; saying "stopped" here would be the one place in this client where
|
|
;; a success message meant "probably".
|
|
(delete-process proc)
|
|
(setq flan--daemon nil
|
|
flan--daemon-socket nil)
|
|
(force-mode-line-update t)
|
|
(user-error
|
|
"flan dev: the daemon would not close and was killed; its program may still be running")))
|
|
(setq flan--daemon nil
|
|
flan--daemon-socket nil)
|
|
(force-mode-line-update t)
|
|
(message "flan dev: stopped"))))
|
|
|
|
;;;###autoload
|
|
(defun flan-restart-program ()
|
|
"Stop the program this Emacs started and start it again from source.
|
|
|
|
For a change the running program cannot take: a struct whose layout moved, a
|
|
function whose signature changed, anything the daemon refuses by telling you
|
|
to restart. There is no smaller version of this. A session's struct layouts
|
|
and global types describe the memory of a process only if that session
|
|
compiled it, so a new layout means a new build, which means a new process and
|
|
the session that made it — and the program's state goes with it, which is the
|
|
whole cost and the reason this is a separate command rather than something
|
|
`C-c C-c' falls back to.
|
|
|
|
The old daemon is waited for before the new one starts, because it unlinks
|
|
the socket on its way out and would otherwise unlink the one its successor
|
|
had just bound. If it will not close and has to be killed, this stops there
|
|
rather than starting a second program on top of one that may still be
|
|
running — `flan' then starts it again, on the same program."
|
|
(interactive)
|
|
(unless (process-live-p flan--daemon)
|
|
(user-error "flan dev: no daemon started from Emacs to restart"))
|
|
;; Refused rather than half-done: this ends a program and builds it again,
|
|
;; and with the connection attached to somebody else's daemon there is no
|
|
;; reading of it that leaves one session where there was one.
|
|
(when (and (process-live-p flan--connection)
|
|
flan--socket flan--daemon-socket
|
|
(not (equal flan--socket flan--daemon-socket)))
|
|
(user-error
|
|
"flan dev: connected to %s, which is not the %s started here; M-x flan-connect to it first"
|
|
(abbreviate-file-name flan--socket)
|
|
(abbreviate-file-name (or flan--file flan--daemon-socket))))
|
|
(let ((file flan--file)
|
|
;; The daemon's socket and not the connection's: what is being
|
|
;; restarted is the program this Emacs started, and the connection may
|
|
;; by now be attached to a second one somewhere else.
|
|
(socket (or flan--daemon-socket flan--socket)))
|
|
(flan-quit) ; returns only once it is really gone
|
|
(flan file socket)))
|
|
|
|
;;; 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-live-face '((t :inherit success))
|
|
"Face for the modeline indicator when a program is connected."
|
|
:group 'flan)
|
|
|
|
(defface flan-lost-face '((t :inherit warning))
|
|
"Face for the modeline indicator when the daemon has gone away."
|
|
:group 'flan)
|
|
|
|
(defface flan-stopped-face '((t :inherit error))
|
|
"Face for the modeline indicator when the program is stopped at a break."
|
|
:group 'flan)
|
|
|
|
(defun flan-state ()
|
|
"Whether a program is connected: `stopped', `parked', `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. `stopped' is a
|
|
live program sitting in the break loop on an unhandled condition, which is
|
|
every bit as connected and nothing like running. `parked' is a program that
|
|
has *finished*: the process and every global in it are still there, and
|
|
`flan-rerun' starts `main' again.
|
|
|
|
`stopped' wins over `parked' where both are somehow set, because a break is
|
|
the state with something to answer in it."
|
|
(cond ((and (process-live-p flan--connection) flan--stopped) 'stopped)
|
|
((and (process-live-p flan--connection) flan--parked) 'parked)
|
|
((process-live-p flan--connection) 'live)
|
|
(flan--socket 'lost)
|
|
(t 'off)))
|
|
|
|
(defun flan-mode-line ()
|
|
"The Flan connection indicator, for `mode-line-misc-info'."
|
|
(when (derived-mode-p 'flan-mode 'flan-repl-mode)
|
|
(pcase (flan-state)
|
|
;; First, and it names the condition: a stopped program looks exactly
|
|
;; like a running one from anywhere else in Emacs, and the whole reason
|
|
;; the break loop is worth having is that someone notices it.
|
|
('stopped (propertize (format " flan:stopped(%s)" flan--stopped)
|
|
'face 'flan-stopped-face
|
|
'help-echo
|
|
"Stopped on an unhandled condition; C-c C-b to choose a restart"))
|
|
;; Before `live', and shown as its own word rather than as a shade of
|
|
;; it: from anywhere else in Emacs a finished program looks exactly like
|
|
;; a running one, and it is the indicator's job to be the thing that
|
|
;; notices. `stopped''s face is reused — both mean "connected, and not
|
|
;; going anywhere until you say so", which is what the colour is for.
|
|
('parked (propertize " flan:parked" 'face 'flan-stopped-face
|
|
'help-echo
|
|
"The program finished; C-c C-M-x runs it again, globals and all"))
|
|
('live (propertize " flan:live" 'face 'flan-live-face
|
|
'help-echo (format "Connected to %s" flan--socket)))
|
|
('lost (propertize " flan:lost" 'face 'flan-lost-face
|
|
'help-echo
|
|
(format "%s has gone away; the next command reconnects"
|
|
flan--socket)))
|
|
(_ (propertize " flan:off" 'face 'shadow
|
|
'help-echo "Not connected (C-c C-z)")))))
|
|
|
|
;; Installed buffer-locally by `flan-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.
|
|
|
|
;;; The break loop
|
|
|
|
;; What a stopped program is for. The condition is the class name and nothing
|
|
;; more — the hook is handed a name and an opaque pointer, and nothing at run
|
|
;; time can render a value whose type it does not know — and the restarts are
|
|
;; the names the frames between the error and the top are offering, innermost
|
|
;; first. `completing-read' over them is the natural shape: they are a closed
|
|
;; set the program computed, so require-match is exactly right.
|
|
;;
|
|
;; What is chosen is a *position* on that list, not a name. §4 says lookup
|
|
;; takes the first frame offering a name, so when two frames offer `retry' the
|
|
;; outer one is real, is on this list, and by name is unreachable — the old
|
|
;; prompt showed `retry' twice and sent the string either way, and the inner
|
|
;; frame took it silently. A position cannot be ambiguous, which is why SBCL
|
|
;; identifies restarts positionally too. So the candidates are numbered and
|
|
;; the number is what goes on the wire.
|
|
;;
|
|
;; `abort' is on the same list rather than on a separate key, because it is the
|
|
;; same decision: it is what you pick when none of the restarts is the answer.
|
|
;; It is last, and it is not the default.
|
|
|
|
(defun flan--restart-candidates (restarts unreachable)
|
|
"Label each of RESTARTS by its position, marking those in UNREACHABLE.
|
|
An alist of label to index. The index leads the label because it is the
|
|
identity: two entries may read the same and mean different frames."
|
|
(let ((i -1))
|
|
(mapcar (lambda (name)
|
|
(setq i (1+ i))
|
|
(cons (format "%d. %s%s" i name
|
|
(if (memq i unreachable)
|
|
" (below this break; cannot be taken)"
|
|
""))
|
|
i))
|
|
restarts)))
|
|
|
|
(defun flan-restart-at (index name)
|
|
"Resume the stopped program at the restart at position INDEX.
|
|
NAME is sent with it and is not the lookup: the program checks it against
|
|
the name it holds at that position and refuses if the two have drifted
|
|
apart, so a prompt cannot take a different restart than the one it showed."
|
|
(let ((r (flan--request (list :op "restart-at" :index index :name name))))
|
|
(if (equal (plist-get r :status) "ok")
|
|
(progn
|
|
;; Accepted, not resumed — see `flan-restart'.
|
|
(setq flan--stopped nil)
|
|
(force-mode-line-update t)
|
|
(message "flan: %s — %s" name (or (plist-get r :note) "accepted")))
|
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))))
|
|
|
|
(defun flan-restart (name)
|
|
"Resume the stopped program at the restart called NAME.
|
|
The first frame offering NAME, which is §4's own rule and therefore cannot
|
|
reach a shadowed one. `flan-break' chooses by position instead; this is
|
|
here for a name known in advance."
|
|
(interactive (list (completing-read "Restart: " (flan-restarts) nil t)))
|
|
(let ((r (flan--request (list :op "restart" :name name))))
|
|
(if (equal (plist-get r :status) "ok")
|
|
(progn
|
|
;; Accepted, not resumed: the choice is validated against the stopped
|
|
;; thread's stack and taken when that thread next comes round its
|
|
;; loop. It is therefore still stopped as this reply is written, and
|
|
;; believing the reply's `:stopped' would leave the modeline saying
|
|
;; so until the poll after the one that agreed. Cleared here and
|
|
;; re-established by the next poll if the program is somehow still
|
|
;; there.
|
|
(setq flan--stopped nil)
|
|
(force-mode-line-update t)
|
|
(message "flan: %s — %s" name
|
|
(or (plist-get r :note) "accepted")))
|
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))))
|
|
|
|
;;;###autoload
|
|
(defun flan-rerun ()
|
|
"Run the program's `main' again, in the process that is already there.
|
|
|
|
For the ordinary end of a session that is not the end of anything: the
|
|
program opened a window, you closed it, `main' returned. The process did
|
|
not go anywhere — it holds the compiler, the session and every global the
|
|
run left — so this sends it round `main' once more and you get another
|
|
window. It is what calling `(main)' at a Common Lisp or Clojure prompt does,
|
|
and it is the cheap counterpart of `flan-restart-program', which throws
|
|
away the build and the state to get a new process.
|
|
|
|
NOTHING IS RESET. The second run reads whatever the first left in the
|
|
globals: a counter goes on counting, an arena is as full as it was. That is
|
|
the point rather than an omission — a clean slate is one evaluation away and
|
|
cannot be had back once this has zeroed something you wanted.
|
|
|
|
Refused while the program is running, by the daemon, because two `main's in
|
|
one process would be writing the same globals at once."
|
|
(interactive)
|
|
(let ((r (flan--request '(:op "rerun"))))
|
|
(if (equal (plist-get r :status) "ok")
|
|
(progn
|
|
;; Cleared here rather than waited for, exactly as a restart clears
|
|
;; `flan--stopped': the reply is written by the compiler thread
|
|
;; the instant it signals, and the modeline would otherwise say
|
|
;; `parked' until the poll after the one that agreed.
|
|
(setq flan--parked nil)
|
|
(force-mode-line-update t)
|
|
(message "flan: %s" (or (plist-get r :note) "running again")))
|
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))))
|
|
|
|
(defun flan-abort ()
|
|
"Let the stopped program die where it stopped.
|
|
This ends `flan dev' too: the daemon owns the program's lifetime and has
|
|
nothing left to serve once it has gone."
|
|
(interactive)
|
|
(let ((r (flan--request '(:op "abort"))))
|
|
(if (equal (plist-get r :status) "ok")
|
|
(progn (setq flan--stopped nil)
|
|
(force-mode-line-update t)
|
|
(message "flan: %s" (or (plist-get r :note) "aborted")))
|
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))))
|
|
|
|
(defun flan-restarts ()
|
|
"The restart names the stopped program is offering, innermost first."
|
|
(let ((r (flan--request '(:op "break"))))
|
|
(unless (equal (plist-get r :status) "ok")
|
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))
|
|
(plist-get r :restarts)))
|
|
|
|
;;;###autoload
|
|
(defun flan-break ()
|
|
"Show what the stopped program is offering, and choose one.
|
|
Refuses while the program is running, by name: there is no restart stack to
|
|
walk from a running program, and a prompt with nothing behind it is worse
|
|
than being told so."
|
|
(interactive)
|
|
(let* ((r (flan--request '(:op "break"))))
|
|
(unless (equal (plist-get r :status) "ok")
|
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))
|
|
(unless flan--stopped
|
|
(user-error "flan: the program is running; nothing is stopped"))
|
|
(let* ((restarts (plist-get r :restarts))
|
|
(unreachable (append (plist-get r :unreachable) nil))
|
|
(table (flan--restart-candidates restarts unreachable))
|
|
(choice
|
|
(completing-read
|
|
(format "flan: stopped on %s%s — " flan--stopped
|
|
(if restarts "" " (no restarts are active)"))
|
|
(append (mapcar #'car table) '("abort")) nil t))
|
|
(index (cdr (assoc choice table))))
|
|
(cond
|
|
((equal choice "abort") (flan-abort))
|
|
;; `require-match' over a table this built, so a choice outside it is
|
|
;; not something a person can type — but deriving the table wrongly
|
|
;; should say so rather than put nil on the wire as an index.
|
|
((null index) (user-error "flan: %s is not on the list" choice))
|
|
(t (flan-restart-at index (nth index restarts)))))))
|
|
|
|
;;;###autoload
|
|
(defun flan-show-output ()
|
|
"Show the running program's output, after collecting anything pending."
|
|
(interactive)
|
|
(ignore-errors (flan--request '(:op "describe")))
|
|
(display-buffer (get-buffer-create flan-output-buffer)))
|
|
|
|
(defun flan-describe ()
|
|
"Report what the running program currently defines."
|
|
(interactive)
|
|
(let ((r (flan--request '(:op "describe"))))
|
|
;; Three states and not two. `:alive' says whether there is still a
|
|
;; session; `:parked' says the program inside it has finished, which is a
|
|
;; thing "exited" used to be told and was wrong about — nothing exited,
|
|
;; and saying so sent people to `flan-restart-program' for something
|
|
;; `flan-rerun' does without losing the build.
|
|
(message "flan dev: %s, %d functions, %d globals"
|
|
(cond ((plist-get r :parked) "parked")
|
|
((plist-get r :alive) "running")
|
|
(t "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--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--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--wire-position (pos)
|
|
"POS as the (LINE COL) pair the daemon reads off a `:pause' field.
|
|
|
|
The inverse of `flan--position', and byte-columns for the same reason:
|
|
the reader walks the source a byte at a time, so `current-column' would be
|
|
short by one per extra byte in every non-ASCII character earlier on the line
|
|
and the daemon would find nothing at the position it was handed.
|
|
|
|
The line is the buffer's own, which is what the daemon sees because
|
|
`flan--text' pads the snippet back onto it."
|
|
(list (line-number-at-pos pos)
|
|
(save-excursion
|
|
(goto-char pos)
|
|
(1+ (- (position-bytes pos)
|
|
(position-bytes (line-beginning-position)))))))
|
|
|
|
(defun flan--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 feedback about the evaluation that just failed and not an annotation
|
|
;; on the source, so it lasts exactly as long as that: the next command in that
|
|
;; buffer takes it away, whatever the command was — a keystroke, a motion,
|
|
;; another evaluation. An overlay that survived until some later evaluation
|
|
;; was accepted outlived the thing it was about, and a stale one is worse than
|
|
;; none.
|
|
;;
|
|
;; `pre-command-hook' and not `post-command-hook': the hook has to run before
|
|
;; the *next* command, because `post-command-hook' fires at the end of the
|
|
;; failing command itself and would take the overlay down before redisplay had
|
|
;; ever drawn it.
|
|
;;
|
|
;; The hook is buffer-local and lives exactly as long as an overlay does —
|
|
;; added where one is drawn, removed where they are cleared. Globally it would
|
|
;; be a hook every buffer in the session runs on every keystroke for the sake
|
|
;; of a feature most of them will never use; buffer-locally it is also the
|
|
;; behaviour asked for, since the overlay belongs to the buffer the failed
|
|
;; evaluation came from and a command somewhere else is not "doing something
|
|
;; else in that buffer".
|
|
|
|
(defface flan-error-face
|
|
'((t :inherit error :underline (:style wave)))
|
|
"Face for the text an evaluation was rejected at."
|
|
:group 'flan)
|
|
|
|
(defface flan-error-message-face
|
|
'((t :inherit error :height 0.9))
|
|
"Face for the message shown beside a rejected form."
|
|
:group 'flan)
|
|
|
|
(defun flan--error-overlays (&optional buffer)
|
|
"The Flan error overlays in BUFFER, or in the current buffer."
|
|
(with-current-buffer (or buffer (current-buffer))
|
|
(seq-filter (lambda (o) (overlay-get o 'flan-error))
|
|
(overlays-in (point-min) (point-max)))))
|
|
|
|
(defun flan-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-error t)
|
|
;; With nothing left to clear there is nothing for the hook to do, and a
|
|
;; hook that stays installed after the last overlay is gone is the half of
|
|
;; this that quietly accumulates.
|
|
(remove-hook 'pre-command-hook #'flan--clear-errors-on-command t)))
|
|
|
|
(defun flan--clear-errors-on-command ()
|
|
"Take this buffer's error overlays down, as a `pre-command-hook'.
|
|
Any command at all, because the overlay is about the evaluation that failed
|
|
and not about the text: moving, typing and evaluating are all something
|
|
else, and an overlay that survived a fix would be pointing at code that is
|
|
no longer wrong."
|
|
(flan-clear-errors))
|
|
|
|
(defun flan--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--parse-loc loc)))
|
|
(when parts
|
|
(let ((buf (flan--buffer-visiting (nth 0 parts))))
|
|
(when buf
|
|
(with-current-buffer buf
|
|
(flan-clear-errors buf)
|
|
;; A refusal is not a value, and the two must never be drawn over
|
|
;; one form at once. Ordinarily the command that ran this
|
|
;; evaluation already cleared the last one through the hook; this
|
|
;; is the case where it did not, because the value being replaced
|
|
;; was drawn by *this* command in another buffer.
|
|
(flan-clear-result buf)
|
|
(let* ((beg (flan--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-error t)
|
|
(overlay-put ov 'face 'flan-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-error-message-face))
|
|
;; Local to this buffer, and installed only now that there is
|
|
;; something for it to remove.
|
|
(add-hook 'pre-command-hook
|
|
#'flan--clear-errors-on-command nil t)
|
|
;; 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)))))))
|
|
|
|
;;; Inline results
|
|
|
|
;; The value of an expression, drawn after the form it came from, the way eros
|
|
;; draws one in Emacs Lisp and CIDER in Clojure. The echo area is the older
|
|
;; half of this and is still there; what it cannot do is answer "which form
|
|
;; was that?", which is the whole question when two expressions on adjacent
|
|
;; lines both return 2.
|
|
;;
|
|
;; The lifetime argument is the error overlay's, above, and it is the same
|
|
;; argument rather than a similar one: this is feedback about the evaluation
|
|
;; that just ran and not an annotation on the source, so the next command in
|
|
;; the buffer takes it away, and it is a `pre-command-hook' for the reason
|
|
;; given there — `post-command-hook' fires at the end of the command that drew
|
|
;; it, before redisplay has ever shown it. That is also the convention people
|
|
;; arrive with from eros.
|
|
;;
|
|
;; The shape is `flan-watch--ghost-text's, deliberately: " => " and a shadow
|
|
;; face. A watched value at a spy site and an expression's value at the form
|
|
;; you evaluated are the same thing seen two ways, and two spellings of it
|
|
;; would read as two features. What keeps them from fighting is that they sit
|
|
;; at different places — the watch's at end of line, this at end of form — and
|
|
;; where a one-line top-level form makes those the same position, two
|
|
;; after-strings at one position stack in priority order rather than one
|
|
;; hiding the other. They are also on different properties, so neither
|
|
;; clearing pass reaches into the other's overlays.
|
|
|
|
(defface flan-result-face '((t :inherit shadow))
|
|
"Face for an expression's value, shown beside the form it came from."
|
|
:group 'flan)
|
|
|
|
(defun flan--result-overlays (&optional buffer)
|
|
"The Flan result overlays in BUFFER, or in the current buffer."
|
|
(with-current-buffer (or buffer (current-buffer))
|
|
(seq-filter (lambda (o) (overlay-get o 'flan-result))
|
|
(overlays-in (point-min) (point-max)))))
|
|
|
|
(defun flan-clear-result (&optional buffer)
|
|
"Remove inline result overlays from BUFFER, or from the current buffer."
|
|
(interactive)
|
|
(with-current-buffer (or buffer (current-buffer))
|
|
(remove-overlays (point-min) (point-max) 'flan-result t)
|
|
(remove-hook 'pre-command-hook #'flan--clear-result-on-command t)))
|
|
|
|
(defun flan--clear-result-on-command ()
|
|
"Take this buffer's result overlays down, as a `pre-command-hook'."
|
|
(flan-clear-result))
|
|
|
|
(defun flan--show-result (value at)
|
|
"Draw VALUE after position AT. Returns non-nil when it drew one.
|
|
|
|
Empty overlays rather than a region: the value is not a property of any text,
|
|
so nothing should be highlighted and nothing should move when the buffer is
|
|
edited under it. Returning whether it drew is what lets the caller fall back
|
|
to the echo area instead of losing the value entirely."
|
|
(when (and flan-inline-result at (buffer-live-p (current-buffer)))
|
|
;; The old one first, so a second evaluation in one command — which is
|
|
;; what `flan-eval-buffer' and a macro of these amount to — leaves one
|
|
;; value and not a column of them.
|
|
(flan-clear-result)
|
|
(let ((ov (make-overlay at at nil t nil)))
|
|
(overlay-put ov 'flan-result t)
|
|
(overlay-put ov 'after-string
|
|
(propertize (concat " => " value)
|
|
'face 'flan-result-face
|
|
;; Without this, point at end of line lands on
|
|
;; the value rather than on the buffer's own
|
|
;; last column. `flan-watch' found this first.
|
|
'cursor t))
|
|
(overlay-put ov 'evaporate nil)
|
|
;; Under an error overlay, which is about one command and should win
|
|
;; while it is up, and over a pause mark, which is an annotation on the
|
|
;; program rather than on this evaluation.
|
|
(overlay-put ov 'priority 90)
|
|
(add-hook 'pre-command-hook #'flan--clear-result-on-command nil t)
|
|
t)))
|
|
|
|
;;; Pause marks
|
|
|
|
;; The other overlay in this file, and deliberately not the same thing. An
|
|
;; error overlay is feedback about the command that just failed and lasts
|
|
;; exactly as long as that — the next keystroke takes it away. A pause mark is
|
|
;; an *annotation on the running program*: the daemon spliced a `(pause)' call
|
|
;; into the declaration it stored, and it will keep stopping there until an
|
|
;; ordinary evaluation replaces that declaration. So it must survive
|
|
;; `pre-command-hook', and it is not on one.
|
|
;;
|
|
;; It is drawn from the reply's `:pause' and never from what was asked for. A
|
|
;; position that matches no form is refused by the daemon, and an overlay drawn
|
|
;; on the request would then be showing a breakpoint that is not there.
|
|
;;
|
|
;; What clears it is what clears the mark itself: an accepted evaluation with
|
|
;; no `:pause' on it, over a region that intersects the mark. `C-c C-k' sends
|
|
;; the whole buffer and therefore clears the whole buffer, which is right —
|
|
;; every declaration in it was just replaced.
|
|
|
|
(defface flan-pause-face
|
|
;; `warning', because `flan-cnr.el' already renders the `Pause' condition in
|
|
;; the conditions buffer as a warning and the two surfaces are about the same
|
|
;; stop. A breakpoint is not a failure.
|
|
'((t :inherit warning :underline t))
|
|
"Face for a form the program will stop at."
|
|
:group 'flan)
|
|
|
|
(defun flan--pause-overlays (&optional buffer)
|
|
"The Flan pause overlays in BUFFER, or in the current buffer."
|
|
(with-current-buffer (or buffer (current-buffer))
|
|
(seq-filter (lambda (o) (overlay-get o 'flan-pause))
|
|
(overlays-in (point-min) (point-max)))))
|
|
|
|
(defun flan-clear-pause (&optional start end)
|
|
"Remove pause marks between START and END, or from the whole buffer.
|
|
Interactively, the whole buffer: the point of asking is to be rid of them."
|
|
(interactive)
|
|
(remove-overlays (or start (point-min)) (or end (point-max))
|
|
'flan-pause t))
|
|
|
|
(defun flan--show-pause (beg end)
|
|
"Mark BEG to END as a form the program will stop at."
|
|
;; The old mark first: re-marking a form that was already marked must leave
|
|
;; one overlay, not two stacked ones whose faces compound.
|
|
(flan-clear-pause beg end)
|
|
(let ((ov (make-overlay beg end nil t nil)))
|
|
(overlay-put ov 'flan-pause t)
|
|
(overlay-put ov 'face 'flan-pause-face)
|
|
(overlay-put ov 'help-echo
|
|
"flan: the program stops here; C-c C-c over it to clear")
|
|
;; Under the error overlays, which are about one command and should win
|
|
;; while they are up.
|
|
(overlay-put ov 'priority 50)
|
|
(overlay-put ov 'evaporate nil)
|
|
ov))
|
|
|
|
;;; 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--defs nil
|
|
"What the running program defines: a list of (NAME KIND SIGNATURE LOC DOC).
|
|
LOC is the empty string where the daemon has none to give. DOC is a line of
|
|
prose, and today only a builtin has one.
|
|
|
|
The list is not only the program's own names: the daemon appends every
|
|
compiler builtin with a KIND of \"builtin\", after the program's, so that
|
|
`arena-new' is a name this end knows about rather than one it reports as
|
|
undefined. Nothing here special-cases them — a builtin is an entry like any
|
|
other, and KIND is what tells it apart where that matters.")
|
|
|
|
(defun flan--forget-defs ()
|
|
"Drop what is known about the program's names."
|
|
(setq flan--defs nil))
|
|
|
|
(defun flan-refresh-defs ()
|
|
"Ask the running program what it defines, and remember it."
|
|
(interactive)
|
|
(setq flan--defs (plist-get (flan--request '(:op "defs")) :defs))
|
|
(when (called-interactively-p 'interactive)
|
|
(message "flan: %d names" (length flan--defs)))
|
|
flan--defs)
|
|
|
|
(defun flan--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--defs)
|
|
(let ((tail (concat "/" name)))
|
|
(let ((hits (seq-filter (lambda (d) (string-suffix-p tail (car d)))
|
|
flan--defs)))
|
|
(and (= 1 (length hits)) (car hits))))))
|
|
|
|
(defun flan--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--defs)))
|
|
(and (> (length hits) 1) hits)))
|
|
|
|
;;; eldoc
|
|
|
|
(defun flan--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-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--enclosing-head)))
|
|
(d (and name (flan--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-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--defs
|
|
(let ((b (bounds-of-thing-at-point 'symbol)))
|
|
(when b
|
|
(list (car b) (cdr b)
|
|
(mapcar #'car flan--defs)
|
|
:annotation-function
|
|
(lambda (n) (let ((d (assoc n flan--defs)))
|
|
(and d (concat " " (nth 1 d)))))
|
|
:company-docsig
|
|
(lambda (n) (let ((d (assoc n flan--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-xref-backend ()
|
|
"The xref backend for a buffer with a running Flan program behind it."
|
|
(and flan--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--defs))
|
|
|
|
(cl-defmethod xref-backend-definitions ((_backend (eql flan)) identifier)
|
|
(let ((d (flan--lookup identifier)))
|
|
(cond
|
|
((null d)
|
|
(if-let ((hits (flan--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)))
|
|
;; Ahead of the empty-location branch: `arena-new' has no location for a
|
|
;; different reason than `ticks' does, and M-. on it should say which.
|
|
;; There is nowhere to jump either way, so this refuses too — but with
|
|
;; the answer to "where is it" rather than with a shrug about the daemon.
|
|
((equal (nth 1 d) "builtin")
|
|
(user-error "flan: %s is a builtin, written in the compiler rather than \
|
|
in this program; C-c C-v describes it" (car d)))
|
|
((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--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)))))))))))))
|
|
|
|
;;; Documentation
|
|
|
|
;; What the daemon already knows about a name, in a buffer rather than in the
|
|
;; echo area. eldoc gives you the signature of the thing you are typing, which
|
|
;; is the right answer while typing and the wrong one when the question is
|
|
;; "what is this?" — a signature that has scrolled past, a kind you are not
|
|
;; sure of, and a location you want to look at rather than jump to.
|
|
;;
|
|
;; Nothing here asks the program anything new: `defs' carries all four facts
|
|
;; already. It is refreshed first when there is a connection, because the
|
|
;; cache is otherwise as old as the last install and a doc buffer is exactly
|
|
;; where a stale signature would be believed.
|
|
|
|
(defvar flan-doc-buffer "*flan-doc*"
|
|
"Buffer `flan-doc' writes into.")
|
|
|
|
(define-derived-mode flan-doc-mode special-mode "Flan-Doc"
|
|
"Mode for the buffer `flan-doc' writes.")
|
|
|
|
(defun flan-doc--goto (loc)
|
|
"Visit LOC, a \"file:line:col\" the daemon gave for a definition."
|
|
(let ((parts (flan--parse-loc loc)))
|
|
(unless parts (user-error "flan: unreadable location: %s" loc))
|
|
(find-file-other-window (nth 0 parts))
|
|
(goto-char (flan--position (nth 1 parts) (nth 2 parts)))))
|
|
|
|
(defun flan-doc--where (d)
|
|
"Insert where D is defined, or why that cannot be said."
|
|
(let* ((loc (nth 3 d))
|
|
(parts (and (not (equal loc "")) (flan--parse-loc loc))))
|
|
(cond
|
|
;; Before the empty-location branch, because a builtin's empty LOC means
|
|
;; something that branch would get wrong. A global was written down and
|
|
;; the Tast dropped where; a builtin was never written down at all, and
|
|
;; "no location is reported for it" would read as a gap in the daemon
|
|
;; rather than as the answer. The answer is the compiler.
|
|
((equal (nth 1 d) "builtin")
|
|
(insert "Defined in the compiler, so there is no file to visit\n"))
|
|
;; Said, not omitted. A missing line reads as "it has no home"; the
|
|
;; truth is that Tast.global and Tast.extern carry no Loc, which is a
|
|
;; fact about the compiler and worth saying in the same words M-. uses.
|
|
((equal loc "")
|
|
(insert (format "Defined the daemon reports no location for a %s\n"
|
|
(nth 1 d))))
|
|
((null parts) (insert (format "Defined at %s, which is unreadable\n" loc)))
|
|
((or (string-match-p "\\`<.*>\\'" (nth 0 parts))
|
|
(not (file-exists-p (nth 0 parts))))
|
|
(insert (format "Defined in %s, which is not a file on disk\n"
|
|
(nth 0 parts))))
|
|
(t
|
|
(insert "Defined ")
|
|
(insert-button (format "%s:%d" (nth 0 parts) (nth 1 parts))
|
|
'action (lambda (_) (flan-doc--goto loc))
|
|
'follow-link t
|
|
'help-echo "Visit this definition")
|
|
(insert "\n")))))
|
|
|
|
;;;###autoload
|
|
(defun flan-doc (name)
|
|
"Show what the running program knows about NAME.
|
|
Interactively, the name at point, or one read with completion when point is
|
|
not on one. Refuses a bare name that could be several packaged ones, in the
|
|
same words `M-.' does: picking one would be a guess about which you meant."
|
|
(interactive
|
|
(list (or (thing-at-point 'symbol t)
|
|
(completing-read "Describe name: " (mapcar #'car flan--defs)
|
|
nil t))))
|
|
(unless flan--defs
|
|
(user-error "flan: nothing is known about any name; connect first (C-c C-z)"))
|
|
(when (process-live-p flan--connection)
|
|
(ignore-errors (flan-refresh-defs)))
|
|
(let ((d (flan--lookup name)))
|
|
(unless d
|
|
(if-let ((hits (flan--ambiguous name)))
|
|
(user-error "flan: %s could be %s; write the one you mean"
|
|
name (string-join (mapcar #'car hits) " or "))
|
|
(user-error "flan: the running program defines no %s" name)))
|
|
(with-current-buffer (get-buffer-create flan-doc-buffer)
|
|
(let ((inhibit-read-only t))
|
|
(erase-buffer)
|
|
(flan-doc-mode)
|
|
(insert (propertize (nth 0 d) 'face 'font-lock-function-name-face) "\n\n")
|
|
(insert (propertize (nth 2 d) 'face 'font-lock-type-face) "\n\n")
|
|
(insert (format "Kind %s\n" (nth 1 d)))
|
|
(flan-doc--where d)
|
|
;; The prose last rather than under the signature, so the four facts
|
|
;; stay the block they have always been and a name with nothing to say
|
|
;; about itself looks exactly as it did before. Filled, because the
|
|
;; daemon sends one line and one line in a narrow window is two.
|
|
(when (and (nth 4 d) (not (equal (nth 4 d) "")))
|
|
(insert "\n")
|
|
(let ((start (point)))
|
|
(insert (nth 4 d) "\n")
|
|
(let ((fill-column (min fill-column 76)))
|
|
(fill-region start (point)))))
|
|
;; Parameter names are not in the Tast — the checker keeps types —
|
|
;; so a signature is types only, and someone reading this buffer
|
|
;; should be told that rather than left to wonder.
|
|
(when (member (nth 1 d) '("fn" "extern"))
|
|
(insert "\nParameter names are not kept past the checker, so a\n"
|
|
"signature shows types only.\n"))
|
|
(goto-char (point-min))))
|
|
(display-buffer flan-doc-buffer)))
|
|
|
|
;;; Wiring it into a buffer
|
|
|
|
(defun flan-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-completion-at-point nil t)
|
|
(add-hook 'xref-backend-functions #'flan-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-eldoc-function nil t)
|
|
(unless (member '(:eval (flan-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-mode-line)))))))
|
|
|
|
(add-hook 'flan-mode-hook #'flan-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-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--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-names-shown) (string-join names ", "))
|
|
(t (format "%d names (%s, …)" (length names)
|
|
(string-join (seq-take names flan-names-shown) ", ")))))
|
|
|
|
(defun flan--report (reply what &optional at)
|
|
"Report REPLY, describing WHAT was sent.
|
|
AT, when given, is where in the current buffer an expression's value may be
|
|
drawn — the end of the form that was sent. A reply with no value in it never
|
|
reaches an overlay whatever AT says, because an install is a sentence and not
|
|
a value and has nothing to sit beside."
|
|
(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.
|
|
;; Redundant now that any command clears it — the command that ran this
|
|
;; evaluation already did — and kept because it is the claim being
|
|
;; made, not the mechanism: an accepted evaluation is never left with a
|
|
;; rejection drawn over it.
|
|
(flan-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-refresh-defs)))
|
|
;; The overlay first, because whether it drew is what decides the echo
|
|
;; area's business: a value shown beside the form does not want saying
|
|
;; again one line below it. Independent of `flan-echo-result' on
|
|
;; purpose — turning the echo off is a statement about the echo, and
|
|
;; it should not silently take the inline value with it.
|
|
(let ((shown (and value (ignore-errors (flan--show-result value at)))))
|
|
(when (and flan-echo-result (not shown))
|
|
(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--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".
|
|
;;
|
|
;; A declaration with no body at all — a `defvar', a `defstruct' —
|
|
;; has none of the first, and leading with WHAT then read as "form
|
|
;; installed in 4 ms (also ticks)": the one name that actually
|
|
;; changed, parenthesised as an afterthought, beside a label that
|
|
;; says nothing. Where there are no functions the names *are* what
|
|
;; changed, so they are what the sentence is about, and the aside
|
|
;; is then empty by construction rather than a repeat of it. Now
|
|
;; that `C-x C-e' reaches this path too, that sentence is also how
|
|
;; you tell an installed declaration from an expression's `=>'.
|
|
(message "flan: %s installed in %.0f ms%s"
|
|
(flan--names-phrase (or fns names) what)
|
|
(or (plist-get reply :ms) 0)
|
|
(let ((vars (and fns (seq-difference names fns))))
|
|
(if vars (format " (also %s)"
|
|
(flan--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)))
|
|
;; A refusal is not a value. `flan--show-error' clears the buffer it
|
|
;; marks, but a rejection the client cannot place — no `:loc', or a file
|
|
;; nobody is visiting — marks nothing, and leaving the last value up
|
|
;; beside a form that was just refused is the lie this prevents.
|
|
(ignore-errors (flan-clear-result))
|
|
(ignore-errors (flan--show-error loc (or msg "rejected")))
|
|
(user-error "flan: %s%s" (or msg "rejected")
|
|
(if loc (format " (%s)" loc) "")))))
|
|
|
|
(defun flan--eval (code what &optional start end pause)
|
|
"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.
|
|
PAUSE, when given, is (BEG . END): the bounds of the form inside CODE the
|
|
program should stop at. Only BEG goes on the wire — the daemon matches it
|
|
against the location the reader attached to that form — and END is what the
|
|
mark is drawn over here. Nothing is inserted in the buffer; see docs/DISCUSS.md
|
|
§9."
|
|
(let ((reply
|
|
(flan--request
|
|
;; buffer-file-name so an error points at the file being edited
|
|
;; rather than at the daemon's placeholder.
|
|
(append
|
|
(list :op "eval" :code code :file (or buffer-file-name "<buffer>"))
|
|
(when pause
|
|
(list :pause (flan--wire-position (car pause))))))))
|
|
;; END as the place a value could go. Every caller of this sends a
|
|
;; declaration and declarations have no value, so this is the path that
|
|
;; stays open rather than one anybody takes today.
|
|
(flan--report reply what end)
|
|
;; `flan--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))
|
|
;; Drawn off the daemon's echo and not off what was asked for, so a mark
|
|
;; the session refused can never be shown as one it took. And an accepted
|
|
;; evaluation *without* a mark is what takes one down: §9's "cleared by an
|
|
;; ordinary C-c C-c", made visible. By the time this runs the daemon has
|
|
;; already replaced the stored declaration with an unmarked one, so the
|
|
;; overlay is the only thing left claiming a breakpoint.
|
|
(cond
|
|
((and pause (plist-get reply :pause))
|
|
(flan--show-pause (car pause) (cdr pause)))
|
|
((and start end) (flan-clear-pause start end)))
|
|
reply))
|
|
|
|
(defun flan--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--text-at (start end)
|
|
"The buffer text from START to END, on the line AND column it is written at.
|
|
|
|
`flan--text' pads lines only, and says why it needs nothing more: a
|
|
top-level form starts at column 1, so the columns already agreed. A macro
|
|
call does not. It is written somewhere inside a `defn', and a refusal the
|
|
daemon reports against it — a macro that never settles is the one that
|
|
happens — carries a column that would otherwise be measured from the start of
|
|
the snippet and drawn at the start of the line.
|
|
|
|
Leading newlines and leading spaces are both whitespace the reader skips, so
|
|
padding with each is the whole fix. Byte columns, for the reason
|
|
`flan--wire-position' gives: the reader walks the source a byte at a time,
|
|
and a space is one byte, so a byte count is exactly how many to write."
|
|
(save-excursion
|
|
(goto-char start)
|
|
(concat (make-string (1- (line-number-at-pos start)) ?\n)
|
|
(make-string (- (position-bytes start)
|
|
(position-bytes (line-beginning-position)))
|
|
?\s)
|
|
(buffer-substring-no-properties start end))))
|
|
|
|
(defun flan--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--defun-at-point ()
|
|
"The text of the top-level form containing or preceding point."
|
|
(let ((b (flan--defun-bounds)))
|
|
(buffer-substring-no-properties (car b) (cdr b))))
|
|
|
|
(defun flan--pause-bounds (b arg)
|
|
"Bounds of the form to mark inside the defun B, for prefix ARG, or nil.
|
|
|
|
Two of §9's three targets, off the same key. One `C-u' marks *the form point
|
|
is inside* — with the cursor at `(+ 1| 1)' the program stops at that `(+ ...)'
|
|
— which is the one you want nine times out of ten, because you put point
|
|
where you want to look. Point not nested inside anything, or two `C-u's,
|
|
marks the top-level form itself: a `defn' cannot be wrapped in a `do', so the
|
|
daemon reads that as stopping on entry instead."
|
|
(cond
|
|
((null arg) nil)
|
|
((and (consp arg) (> (prefix-numeric-value arg) 4)) b)
|
|
(t (or (save-excursion
|
|
(condition-case nil
|
|
(progn (backward-up-list)
|
|
;; The top-level form is its own case above; walking out
|
|
;; to it from inside would silently give "stop on entry"
|
|
;; to someone who asked to stop at a sub-expression.
|
|
(and (> (point) (car b))
|
|
(cons (point) (progn (forward-sexp) (point)))))
|
|
(scan-error nil)))
|
|
b))))
|
|
|
|
;; Which of the two evaluators a key runs is decided by the form it would
|
|
;; send, not by where the cursor is sitting. Point inside a `defn' body, on
|
|
;; `(+ ticks 1)', must still evaluate that expression under `C-x C-e' — the
|
|
;; enclosing `defn' is not what was asked for and reinstalling it would be a
|
|
;; different command. `C-c C-c' picks a different form, and asks the same
|
|
;; question of it: the top-level form point is *in*, which for a bare
|
|
;; `(+ 1 1)' written at column 1 is that expression and nothing else.
|
|
;;
|
|
;; Hardcoded, which is the thing to be careful about: the authority is the
|
|
;; declaration arm of `Parse.expr' in lib/parse.ml (the "is a top-level
|
|
;; declaration, not an expression" refusal, around line 458), plus the
|
|
;; `declare'/`declare-c' arm a few forms below it. This list is that set and
|
|
;; has to be changed with it. `defunion' is being renamed `defdata', with
|
|
;; `defunion' becoming a C-style untagged union; both spellings are top-level
|
|
;; declarations either way, so this list wants `defdata' adding when that
|
|
;; lands rather than a swap.
|
|
;;
|
|
;; `package' is deliberately not here even though flan-mode.el's
|
|
;; `flan--definers' has it. This is the set of heads that *fail* when sent to
|
|
;; the expression evaluator, which is the bug `C-x C-e' was fixed for, and a
|
|
;; `package' form does not fail — `Parse.expr' has no arm refusing it. It is
|
|
;; still a declaration, so `C-c C-c' has to keep installing it; see
|
|
;; `flan--defun-heads' below, which is this list plus that one head.
|
|
(defconst flan--declaration-heads
|
|
'("defmacro" "defn" "defvar" "defconst" "defstruct" "defunion" "defenum"
|
|
"defalias" "import" "declare" "declare-c")
|
|
"Heads whose form is a declaration, and never an expression.")
|
|
|
|
;; The two keys ask *nearly* the same question, and `package' is where the two
|
|
;; readings come apart. `C-x C-e' asks "would this fail if I sent it to the
|
|
;; expression evaluator?", and a `package' form would not: `Parse.expr' has no
|
|
;; arm refusing it, so it falls through to a call of an unknown name and the
|
|
;; message would be a worse one than the declaration path gives. `C-c C-c'
|
|
;; asks the plain question — "is this a declaration?" — and `package' is one:
|
|
;; `Parse.decl' has an arm for it, `C-c C-c' has always installed it, and
|
|
;; routing it to the expression evaluator would take that away.
|
|
(defconst flan--defun-heads (cons "package" flan--declaration-heads)
|
|
"Heads `C-c C-c' recompiles and installs rather than evaluating.")
|
|
|
|
(defun flan--declaration-head-at (pos &optional heads)
|
|
"HEAD when the form starting at POS is one of HEADS, at top level, else nil.
|
|
HEADS defaults to `flan--declaration-heads'.
|
|
|
|
Two questions, and both have to answer yes. The depth at POS says whether
|
|
the form is top-level — `syntax-ppss' at the open delimiter reports the depth
|
|
*before* it, so a form nobody has nested reads as 0 — and that is what keeps
|
|
an inner expression inside a `defn' body on the expression path even when the
|
|
enclosing form is a declaration. The head then says whether the thing is a
|
|
declaration at all, which is what leaves a bare `(+ 1 1)' at column 1 alone.
|
|
|
|
Requiring both rather than the head alone is the more conservative of the two
|
|
readings, and the one the user asked for: a `defn' written inside a `let' is
|
|
not a definition of anything, and installing it as one would quietly accept
|
|
code the compiler is right to refuse. Sent as an expression it gets the
|
|
parser's own message, which says exactly that.
|
|
|
|
The remaining condition is that the form is not inside a string or a comment,
|
|
where a `defn' is prose and not a definition. The depth says nothing about
|
|
that: a form at column 1 inside a comment is at depth 0 like any other.
|
|
|
|
One known limit, left as one: `syntax-ppss' reports depth from the accessible
|
|
portion of the buffer, so in a narrowed buffer a form that is nested in the
|
|
file reads as top-level here. Widening to ask would be a different decision
|
|
about what `C-x C-e' means in a narrowed buffer, and it is not this one's to
|
|
make."
|
|
(save-excursion
|
|
;; Every `syntax-ppss' call before the `looking-at' below: it moves point
|
|
;; and clobbers the match data, and the head is read back out of that
|
|
;; match.
|
|
(let ((state (syntax-ppss pos)))
|
|
(goto-char pos)
|
|
(and (zerop (car state))
|
|
(not (nth 3 state)) ; inside a string
|
|
(not (nth 4 state)) ; inside a comment
|
|
(looking-at "([ \t\n]*\\(\\(?:\\sw\\|\\s_\\)+\\)")
|
|
(member (match-string-no-properties 1)
|
|
(or heads flan--declaration-heads))
|
|
(match-string-no-properties 1)))))
|
|
|
|
(defun flan--declaration-before-point ()
|
|
"The top-level declaration `C-x C-e' would send, as (HEAD START END), or nil.
|
|
|
|
`flan--declaration-head-at' asks the two questions; this one finds the form to
|
|
ask them about, and has a third of its own before either is worth asking:
|
|
there must *be* a form before point. `backward-sexp' does not signal when
|
|
there is nothing behind it — it goes to the beginning of the buffer and stays
|
|
there, which at point-min is no movement at all — and the form it then looks
|
|
at is the one *after* point, whose head is very likely a declaration and whose
|
|
text is empty. `C-x C-e' at the top of a file used to install that: a `defn'
|
|
by name, with no body, out of a region zero characters wide. So START must
|
|
have moved."
|
|
(save-excursion
|
|
(let ((end (point)))
|
|
(condition-case nil
|
|
(progn
|
|
(backward-sexp)
|
|
(let ((start (point)))
|
|
(and (> end start)
|
|
(let ((head (flan--declaration-head-at start)))
|
|
(and head (list head start end))))))
|
|
(scan-error nil)))))
|
|
|
|
(defun flan--eval-expression (start end arg)
|
|
"Evaluate START..END in the running program as an expression, and report it.
|
|
|
|
One function and not one per key, because \"the two keys do the same thing on
|
|
an expression\" is the whole of what routing buys: two call sites assembling
|
|
their own `eval-expr' request is exactly how they drift apart again.
|
|
|
|
ARG is a flag rather than a position. The expression sent *is* the target, so
|
|
the daemon wraps it in a `(pause)' before checking it and the thunk breaks
|
|
where it stands; there is no inside for a position to point at, which is also
|
|
why one `C-u' and two mean the same thing here.
|
|
|
|
`flan--text-at' rather than `flan--text': an expression is not a top-level
|
|
form and does not start at column 1, so a refusal the daemon reports against
|
|
it carries a column measured from the start of the snippet. Padding both ways
|
|
is what puts the error overlay on the character it is about — and the overlay
|
|
this draws on success would otherwise be competing with one drawn at line 1."
|
|
(flan--report
|
|
(flan--request
|
|
(append
|
|
(list :op "eval-expr" :code (flan--text-at start end)
|
|
:file (or buffer-file-name "<buffer>"))
|
|
(when arg (list :pause t))))
|
|
"expression"
|
|
end))
|
|
|
|
;;;###autoload
|
|
(defun flan-eval-defun (&optional arg)
|
|
"Evaluate the top-level form at point in the running program.
|
|
|
|
A declaration — a `defn', a `defvar', anything in `flan--defun-heads' — is
|
|
recompiled and installed, which is what this key has always done. Anything
|
|
else is an expression, and is evaluated and its value shown, because a bare
|
|
`(+ 1 1)' written at the top of a file is a form like any other and refusing
|
|
it was an editor artifact rather than a property of the language. Every other
|
|
Lisp's `C-M-x' does the natural thing with whatever is under it, and so does
|
|
this one.
|
|
|
|
`C-c C-c' and `C-M-x' are one command and both route. Splitting them would
|
|
mean two docstrings and a rule to remember, and nothing is bought by it:
|
|
somebody who writes an expression and presses `C-c C-c' has exactly the
|
|
complaint that made this change, and `C-c C-c' with point inside a `defn' is
|
|
untouched either way — the form picked is still the enclosing declaration, and
|
|
`C-c C-k' is still the key that means \"declarations, all of them\".
|
|
|
|
With a prefix ARG on the declaration path, also mark a form inside it so the
|
|
program stops there when it next runs — `C-u' the form point is inside, `C-u
|
|
C-u' the top-level form itself, which means stopping on entry. The buffer is
|
|
not edited: the daemon is told where the form is and splices the call in after
|
|
parsing, so every location in the file stays where it was. The mark sticks
|
|
until the same form is evaluated without a prefix.
|
|
|
|
On the expression path a prefix is a flag and cannot be anything else, exactly
|
|
as it is for `C-u C-x C-e': the expression sent is the target, and the mark
|
|
does not stick because a thunk is built and thrown away, leaving no
|
|
declaration for it to live in."
|
|
(interactive "P")
|
|
(let* ((b (flan--defun-bounds))
|
|
;; The head is asked of the form's *start* rather than of point, so
|
|
;; the question is about the form `C-c C-c' already picked and the
|
|
;; selection rule is untouched. `flan--defun-bounds' takes the form
|
|
;; point is inside; `flan--declaration-before-point' takes the one
|
|
;; behind point, and swapping this to that would silently turn
|
|
;; `C-c C-c' from the middle of a `defn' body into `C-x C-e'.
|
|
(head (and (< (car b) (cdr b))
|
|
(flan--declaration-head-at (car b) flan--defun-heads))))
|
|
(cond
|
|
(head (flan--eval (flan--text (car b) (cdr b)) "form" (car b) (cdr b)
|
|
(flan--pause-bounds b arg)))
|
|
;; An empty buffer, or point past the last form in one with nothing at
|
|
;; all behind it: `beginning-of-defun' and `end-of-defun' both stay put
|
|
;; and the bounds come back zero characters wide. Sending that asks the
|
|
;; daemon to evaluate the empty string, which it answers — an empty
|
|
;; program is a valid one — and the echo area then reports a success for
|
|
;; an evaluation nobody made. The same refusal `C-x C-e' gives.
|
|
((= (car b) (cdr b))
|
|
(user-error "flan: no top-level form at point to evaluate"))
|
|
(t
|
|
;; `end-of-defun' does not stop at the closing paren: `lisp.el' skips
|
|
;; the blanks after it and then steps over the newline, so END is the
|
|
;; start of the *next* line in every file that ends a line after a form
|
|
;; — which is every file. The declaration path never noticed, because
|
|
;; a newline more or less in the text sent changes nothing. This one
|
|
;; draws a value at END, and at the untrimmed one it lands in column 0
|
|
;; of the line below, over the gap before the next form.
|
|
(let ((end (save-excursion (goto-char (cdr b))
|
|
(skip-chars-backward " \t\n")
|
|
(point))))
|
|
(flan--eval-expression (car b) end arg)
|
|
;; Flashed for the reason the declaration path flashes: point may be
|
|
;; nowhere near the form `beginning-of-defun' actually found, and the
|
|
;; value alone does not say which one that was. Only on success —
|
|
;; `flan--report' signals on a rejection.
|
|
(pulse-momentary-highlight-region (car b) end))))))
|
|
|
|
;;;###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--eval (buffer-substring-no-properties (point-min) (point-max))
|
|
(buffer-name))
|
|
;; `flan--eval' signals on a rejection, so reaching here means every
|
|
;; declaration in the buffer was just replaced by an unmarked one — and
|
|
;; therefore that every mark in it is gone. Done here rather than by passing
|
|
;; bounds, because those are also what gets flashed and pulsing a whole
|
|
;; buffer is not feedback, it is a flicker.
|
|
(flan-clear-pause))
|
|
|
|
;;;###autoload
|
|
(defun flan-eval-last-sexp (&optional arg)
|
|
"Evaluate the form before point in the running program and report it.
|
|
|
|
An expression is compiled into a thunk the program runs at its next frame
|
|
boundary, and its value is shown. A top-level declaration — a `defvar', a
|
|
`defn', anything in `flan--declaration-heads' — is compiled and installed
|
|
instead, and the reply names what changed. The compiler has always had both
|
|
paths; this key used to reach only the first, so a `defvar' typed at the top
|
|
of a file came back as \"defvar is a top-level declaration, not an
|
|
expression\" and the only way to evaluate it was `C-c C-c'. That was an
|
|
editor artifact and not a property of the language.
|
|
|
|
`flan--declaration-before-point' decides which, off the form that would be
|
|
sent rather than off where point is. `C-c C-c' routes the same way now, but
|
|
off a different form — the one point is *inside* — so it stays the explicit
|
|
\"reload the definition I am standing in\" command and is still the one to use
|
|
from inside a body.
|
|
|
|
With a prefix ARG, stop there instead. For an expression that is a flag and
|
|
not a position — the expression sent *is* the target, and it is wrapped in a
|
|
`(pause)' before it is checked, so the thunk breaks where it stands and the
|
|
break loop gets the frame. For a declaration it is a position, because a
|
|
declaration has an inside: the mark goes on the form itself, which the daemon
|
|
reads as stopping on entry, the same as `C-u C-u C-c C-c'.
|
|
|
|
An expression's mark does not stick and cannot — a thunk is built and thrown
|
|
away, so there is no declaration for it to live in — while a declaration's
|
|
does, until the same form is evaluated again without a prefix."
|
|
(interactive "P")
|
|
(let ((decl (flan--declaration-before-point)))
|
|
(if decl
|
|
(pcase-let ((`(,head ,start ,end) decl))
|
|
;; `flan--text', not `flan--text-at': a top-level form starts
|
|
;; at column 1, so the line padding is the whole fix and the columns
|
|
;; already agree. HEAD is what the echo area falls back to when the
|
|
;; daemon installed no bodies and declared no names.
|
|
(flan--eval (flan--text start end) head start end
|
|
(and arg (cons start end))))
|
|
(let ((start (save-excursion
|
|
(condition-case nil (backward-sexp) (scan-error nil))
|
|
(point))))
|
|
;; Nothing behind point is nothing to send. `backward-sexp' does not
|
|
;; signal at the beginning of a buffer, it simply stays there, so the
|
|
;; region measured out is empty and the daemon is asked to evaluate
|
|
;; the empty string — which it answers, since an empty program is a
|
|
;; valid one, and the echo area then reports a success for an
|
|
;; evaluation nobody made. Saying so is the honest answer, and it is
|
|
;; also the answer to the likelier reading: point is at the top of the
|
|
;; file and the form meant was the one *after* it.
|
|
(when (= start (point))
|
|
(user-error "flan: no form before point to evaluate"))
|
|
(flan--eval-expression start (point) arg)))))
|
|
|
|
;;;###autoload
|
|
(defun flan-eval-region (start end)
|
|
"Recompile the top-level forms between START and END."
|
|
(interactive "r")
|
|
(flan--eval (flan--text start end) "region" start end))
|
|
|
|
;;; Disassembly
|
|
|
|
;; `flan emit --dev' prints the IR a source file would compile to. This asks a
|
|
;; different question: what did the code the running program is calling for
|
|
;; this name actually come out as. Only the daemon can answer it, because the
|
|
;; daemon compiled every module it sent and still has both the .ll and the .so
|
|
;; — so the editor asks rather than shelling out to a compiler of its own,
|
|
;; which would show what the source says today and not what was installed.
|
|
;;
|
|
;; The header is SBCL's habit: say which function, from where, and out of
|
|
;; which object, before a line of code. The one line that matters most is
|
|
;; `showing', which is the daemon's own account of how much its answer claims
|
|
;; — there is no way to read an indirection cell back, so a body that has been
|
|
;; delivered is not thereby known to be installed, and the buffer says which of
|
|
;; the two it is looking at rather than letting the listing imply the stronger
|
|
;; one.
|
|
|
|
(defvar flan-disassembly-buffer "*flan-disassembly*"
|
|
"Buffer `flan-disassemble' writes into.")
|
|
|
|
(define-derived-mode flan-disassembly-mode special-mode "Flan-Disasm"
|
|
"Mode for the buffer `flan-disassemble' writes."
|
|
(setq-local truncate-lines t))
|
|
|
|
(defun flan-disassemble--header (label text)
|
|
"Insert a header line naming LABEL with TEXT, wrapped under the label."
|
|
(let ((fill-column 78)
|
|
(start (point)))
|
|
(insert (format "; %-11s %s\n" label text))
|
|
(fill-region start (point))
|
|
;; `fill-region' breaks the line but does not carry the comment character
|
|
;; onto the continuation, and a listing whose header stops being a comment
|
|
;; halfway down reads as output rather than as commentary.
|
|
(save-excursion
|
|
(goto-char start)
|
|
(forward-line 1)
|
|
(while (< (point) (point-max))
|
|
(insert "; ")
|
|
(forward-line 1)))
|
|
(put-text-property start (point) 'face 'font-lock-comment-face)))
|
|
|
|
;;;###autoload
|
|
(defun flan-disassemble (name &optional ir)
|
|
"Show the code NAME last compiled to in the running program's own build.
|
|
|
|
With a prefix argument, or non-nil IR, show the LLVM IR the body was built
|
|
from instead of the machine code it was assembled to.
|
|
|
|
The name is resolved the way `M-.' resolves one: exactly first, then as the
|
|
tail of exactly one packaged name, because a buffer inside a package writes
|
|
`settle' for what the program calls `sim/settle'."
|
|
(interactive
|
|
(list (or (thing-at-point 'symbol t)
|
|
(completing-read
|
|
"Disassemble: "
|
|
(mapcar #'car (seq-filter (lambda (d) (equal (nth 1 d) "fn"))
|
|
flan--defs))
|
|
nil t nil nil
|
|
(and (fboundp 'flan-current-defun-name)
|
|
(flan-current-defun-name))))
|
|
current-prefix-arg))
|
|
(when (process-live-p flan--connection)
|
|
(ignore-errors (flan-refresh-defs)))
|
|
(let* ((d (flan--lookup name))
|
|
;; Ambiguity is refused here rather than sent: the daemon would find
|
|
;; no such name and say so, which is true and useless — it is this end
|
|
;; that knows the buffer wrote a short name and that several program
|
|
;; names end in it.
|
|
(_ (unless d
|
|
(when-let ((hits (flan--ambiguous name)))
|
|
(user-error "flan: %s could be %s; write the one you mean"
|
|
name (string-join (mapcar #'car hits) " or ")))))
|
|
(full (if d (nth 0 d) name))
|
|
(form (if ir "ir" "asm"))
|
|
(r (flan--request (list :op "disassemble" :name full :form form))))
|
|
(unless (equal (plist-get r :status) "ok")
|
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))
|
|
(with-current-buffer (get-buffer-create flan-disassembly-buffer)
|
|
(let ((inhibit-read-only t))
|
|
(erase-buffer)
|
|
(flan-disassembly-mode)
|
|
(let ((start (point)))
|
|
(insert (format "; %s for %s\n"
|
|
(if ir "LLVM IR" "disassembly") full))
|
|
(put-text-property start (point) 'face 'font-lock-comment-face))
|
|
(flan-disassemble--header "signature" (plist-get r :signature))
|
|
(flan-disassemble--header "source" (plist-get r :loc))
|
|
(flan-disassemble--header
|
|
"generation"
|
|
(let ((g (plist-get r :generation)))
|
|
(if (and (numberp g) (zerop g))
|
|
"0 (the build the program was launched from)"
|
|
(format "%s" g))))
|
|
(flan-disassemble--header "object" (plist-get r :object))
|
|
(flan-disassemble--header "showing" (plist-get r :basis))
|
|
(when (plist-get r :note)
|
|
(flan-disassemble--header "note" (plist-get r :note)))
|
|
(insert "\n")
|
|
(insert (plist-get r :text))
|
|
(goto-char (point-min))))
|
|
(display-buffer flan-disassembly-buffer)))
|
|
|
|
;;;###autoload
|
|
(defun flan-disassemble-ir (name)
|
|
"Show the LLVM IR NAME's installed body was built from.
|
|
`flan-disassemble' with a prefix argument does the same thing; this exists so
|
|
that the IR half is findable by name rather than only by a modifier."
|
|
(interactive
|
|
(list (or (thing-at-point 'symbol t)
|
|
(completing-read
|
|
"LLVM IR for: "
|
|
(mapcar #'car (seq-filter (lambda (d) (equal (nth 1 d) "fn"))
|
|
flan--defs))
|
|
nil t))))
|
|
(flan-disassemble name t))
|
|
|
|
;;; What a macro call expands to
|
|
|
|
;; CIDER's `C-c C-m', and the reason it arrives now rather than with macros
|
|
;; themselves: a macro is importable from a package, so `(rl/with-drawing ...)'
|
|
;; is a call whose `defmacro' lives in another directory. Until the editor can
|
|
;; ask, there is nothing to read beside the call site at all — and the answer
|
|
;; is not in the file either way, because a macro answers a `Form' and nobody
|
|
;; ever wrote that down.
|
|
;;
|
|
;; Two commands off one key, the way `C-c C-a' already does it: `C-c C-m' is
|
|
;; one step and `C-u C-c C-m' is all the way. One step is the bare key because
|
|
;; it is the one that can name the macro that ran. A macro may quasiquote a
|
|
;; call to another macro — `mac/quad' answers `(mac/twice (mac/twice n))' — and
|
|
;; `Loc.from_macro' is outermost-wins, so by the time a full expansion settles
|
|
;; every node of it is stamped with the name the author wrote and the
|
|
;; intermediate ones are gone. All the way is the answer the compiler acts on;
|
|
;; one step is how you find out which macro produced what.
|
|
;;
|
|
;; The buffer is `flan-mode', because what it holds is Flan source and the
|
|
;; whole point is to read it: the indentation and the font-lock are this
|
|
;; project's own. Three keys are shadowed for exactly that reason — the text
|
|
;; in here is *not* the text of any file, it has no locations of its own, and
|
|
;; `C-c C-c' over it would install a body nobody wrote under a name somebody
|
|
;; did.
|
|
;;
|
|
;; From cnr, the idea rather than the code: a key that expands in place. `C-c
|
|
;; C-m' inside the buffer takes the form at point one more step and puts the
|
|
;; result where it was, which is what makes one-step-by-default usable rather
|
|
;; than a thing you press twice and lose. cnr's own folding is frame-and-locals
|
|
;; machinery with its own text properties and there is nothing here to fold.
|
|
|
|
(defcustom flan-macroexpansion-buffer "*flan-macroexpansion*"
|
|
"Where `flan-macroexpand' draws."
|
|
:type 'string)
|
|
|
|
(defvar flan-macroexpand-request-function #'flan--request
|
|
"How the macroexpansion buffer reaches the daemon.
|
|
One plist in, the reply plist out. A variable for `flan-cnr-request-function''s
|
|
reason: so the renderer can be driven from a fixture.")
|
|
|
|
(defvar-local flan-macroexpand--origin nil
|
|
"What this buffer is showing, as a plist: :code, :file and :all.
|
|
`g' re-asks it, so an expansion can be refreshed after the `defmacro' behind
|
|
it has been re-evaluated.")
|
|
|
|
(defun flan-macroexpand--bounds ()
|
|
"Bounds of the form to expand, as (START . END).
|
|
|
|
The form before point, which is the region `C-x C-e' chooses and the one
|
|
CIDER's own macroexpand uses — and the form *at* point when point sits on its
|
|
opening delimiter, which `C-x C-e' has no need of and this does. A macro call
|
|
is a form you put point on; `backward-sexp' from an open paren takes the
|
|
previous sibling, which is never what was meant."
|
|
(save-excursion
|
|
(skip-chars-forward " \t")
|
|
(if (looking-at-p "[([{]")
|
|
(cons (point) (save-excursion (forward-sexp) (point)))
|
|
(let ((end (point)))
|
|
(backward-sexp)
|
|
(cons (point) end)))))
|
|
|
|
(defun flan-macroexpand--ask (code file all)
|
|
"Ask the daemon what CODE, written in FILE, expands to.
|
|
ALL asks for the fixpoint rather than one step. Answers the reply plist, or
|
|
signals — having drawn the refusal where it happened, which is why the caller
|
|
sends padded text."
|
|
(let ((r (funcall flan-macroexpand-request-function
|
|
(list :op "macroexpand" :code code :file file
|
|
:all (if all t nil)))))
|
|
(unless (equal (plist-get r :status) "ok")
|
|
(let ((loc (plist-get r :loc))
|
|
(msg (plist-get r :message)))
|
|
;; The two refusals that reach here are a macro that never settles and
|
|
;; a ring, and both name a macro at a location — so mark it, exactly as
|
|
;; a refused evaluation is marked. This must not itself signal: the
|
|
;; error the caller is owed is the daemon's.
|
|
(ignore-errors (flan--show-error loc (or msg "refused")))
|
|
(user-error "flan: %s%s" (or msg "refused")
|
|
(if loc (format " (%s)" loc) ""))))
|
|
r))
|
|
|
|
(defun flan-macroexpand--insert-code (text)
|
|
"Insert TEXT as code and let `flan-mode' decide its columns.
|
|
`Form.pretty' puts the line breaks in — that is structure, and a printer has
|
|
to choose it — and stops there. Where the columns go is this project's
|
|
indentation, which lives in `flan-mode' and not in the compiler."
|
|
(let ((start (point))
|
|
;; `indent-region' reports its progress, which is noise in the echo
|
|
;; area over a form and a hundred lines of it in a batch run.
|
|
(inhibit-message t))
|
|
(insert text "\n")
|
|
(indent-region start (point))))
|
|
|
|
(defun flan-macroexpand--render (reply code file all)
|
|
"Draw REPLY, the expansion of CODE from FILE, into the macroexpansion buffer."
|
|
(with-current-buffer (get-buffer-create flan-macroexpansion-buffer)
|
|
(let ((inhibit-read-only t))
|
|
(erase-buffer)
|
|
(flan-macroexpansion-mode)
|
|
(setq flan-macroexpand--origin (list :code code :file file :all all))
|
|
(let ((start (point)))
|
|
(insert (format "; macroexpansion, %s\n"
|
|
(if all "all the way" "one step")))
|
|
(put-text-property start (point) 'face 'font-lock-comment-face))
|
|
(flan-disassemble--header "of" (string-trim code))
|
|
(flan-disassemble--header
|
|
"macro" (or (plist-get reply :macro)
|
|
"none — the head of this form is not a macro"))
|
|
;; What `Loc.from_macro' means for what is printed, said here because
|
|
;; there is nowhere else it could be said. Every node below carries the
|
|
;; *call site's* file, line and column with the macro's name stamped on
|
|
;; it, so an error in expanded code points at the call you wrote. None of
|
|
;; it has a location of its own, nothing in it is the text of any file,
|
|
;; and there is nothing here for `M-.' to jump to.
|
|
(flan-disassemble--header
|
|
"locations"
|
|
(format "every node below carries %s's own %s, tagged with the macro \
|
|
that produced it; the text has no locations of its own and is not in any file"
|
|
(file-name-nondirectory file)
|
|
(if (plist-get reply :macro) "line and column" "position")))
|
|
(when (plist-get reply :note)
|
|
(flan-disassemble--header "note" (plist-get reply :note)))
|
|
(insert "\n")
|
|
(flan-macroexpand--insert-code (plist-get reply :text))
|
|
;; Point on the code rather than on the header. Found by the blank line
|
|
;; that separates them and not by counting: a header line is filled, so
|
|
;; a long one is two lines and a count would drift onto it.
|
|
(goto-char (point-min))
|
|
(if (re-search-forward "^$" nil t) (forward-line 1) (goto-char (point-min)))))
|
|
(display-buffer flan-macroexpansion-buffer))
|
|
|
|
;;;###autoload
|
|
(defun flan-macroexpand (&optional all)
|
|
"Show what the macro call before point expands to.
|
|
|
|
One step, which is the one that can name the macro that ran. With a prefix
|
|
argument, or non-nil ALL, expand to the fixpoint instead — a macro may
|
|
quasiquote a call to another macro, so the two genuinely differ.
|
|
|
|
The form is expanded against the macros this *session* holds: the prelude's,
|
|
the ones its imports brought in, and every `defmacro' evaluated since it
|
|
started. Not a fresh read of the file, which would answer with what is saved
|
|
rather than with what is typed."
|
|
(interactive "P")
|
|
(let* ((b (flan-macroexpand--bounds))
|
|
(file (or buffer-file-name "<buffer>"))
|
|
;; Padded onto its own line *and column*, unlike `C-x C-e', because
|
|
;; the refusals this path can get name a location inside the snippet
|
|
;; and a macro call is written well inside a line.
|
|
(code (flan--text-at (car b) (cdr b)))
|
|
(r (flan-macroexpand--ask code file all)))
|
|
(flan-macroexpand--render r (buffer-substring-no-properties (car b) (cdr b))
|
|
file all)
|
|
(pulse-momentary-highlight-region (car b) (cdr b))
|
|
(unless (plist-get r :expanded)
|
|
(message "flan: %s" (or (plist-get r :note) "nothing expanded")))
|
|
r))
|
|
|
|
;;;###autoload
|
|
(defun flan-macroexpand-all ()
|
|
"Expand the macro call before point to its fixpoint.
|
|
`flan-macroexpand' with a prefix argument does the same thing; this exists so
|
|
the other half is findable by name and not only by a modifier."
|
|
(interactive)
|
|
(flan-macroexpand t))
|
|
|
|
(defun flan-macroexpand-again (&optional all)
|
|
"Expand the form at point one more step, in place.
|
|
|
|
The buffer holds code with no file behind it, so the expansion replaces the
|
|
text it came from rather than opening anything. With a prefix argument, or
|
|
non-nil ALL, take it all the way instead."
|
|
(interactive "P")
|
|
(unless flan-macroexpand--origin
|
|
(user-error "flan: this is not a macroexpansion buffer"))
|
|
(let* ((b (flan-macroexpand--bounds))
|
|
(code (buffer-substring-no-properties (car b) (cdr b)))
|
|
;; Unpadded, and that is the honest shape here: this text is in no
|
|
;; file, so there is no line or column for a refusal to be drawn at.
|
|
;; The file still goes on the wire — it is what tells the daemon which
|
|
;; session's macros to expand against.
|
|
(r (flan-macroexpand--ask code (plist-get flan-macroexpand--origin :file)
|
|
all)))
|
|
(if (not (plist-get r :expanded))
|
|
(message "flan: %s" (or (plist-get r :note) "nothing expanded"))
|
|
(let ((inhibit-read-only t)
|
|
(start (car b)))
|
|
(delete-region (car b) (cdr b))
|
|
(goto-char start)
|
|
;; No trailing newline from `--insert-code': this is a form inside a
|
|
;; line, not a section.
|
|
(let ((from (point)))
|
|
(insert (plist-get r :text))
|
|
(indent-region from (point))
|
|
(pulse-momentary-highlight-region from (point)))
|
|
(goto-char start))
|
|
(message "flan: %s" (or (plist-get r :macro) "expanded")))))
|
|
|
|
(defun flan-macroexpand-all-again ()
|
|
"Expand the form at point to its fixpoint, in place."
|
|
(interactive)
|
|
(flan-macroexpand-again t))
|
|
|
|
(defun flan-macroexpand-refresh ()
|
|
"Ask again for the expansion this buffer is showing.
|
|
The `defmacro' behind it may have been re-evaluated since, and an expansion
|
|
drawn from the old body is exactly the staleness this whole feature exists to
|
|
remove."
|
|
(interactive)
|
|
(unless flan-macroexpand--origin
|
|
(user-error "flan: this is not a macroexpansion buffer"))
|
|
(let* ((o flan-macroexpand--origin)
|
|
(r (flan-macroexpand--ask (plist-get o :code) (plist-get o :file)
|
|
(plist-get o :all))))
|
|
(flan-macroexpand--render r (plist-get o :code) (plist-get o :file)
|
|
(plist-get o :all))))
|
|
|
|
(defun flan-macroexpand--not-source ()
|
|
"Refuse to evaluate the contents of the macroexpansion buffer."
|
|
(interactive)
|
|
(user-error
|
|
"flan: this is an expansion, not source — it is in no file, and installing \
|
|
it would redefine a name with code nobody wrote"))
|
|
|
|
(defvar flan-macroexpansion-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
;; The three that would send this buffer's text to the daemon as though it
|
|
;; were a file. Inherited from `flan-mode-map' and shadowed by name rather
|
|
;; than by unbinding, so pressing one says why instead of doing nothing.
|
|
(define-key map (kbd "C-c C-c") #'flan-macroexpand--not-source)
|
|
(define-key map (kbd "C-c C-k") #'flan-macroexpand--not-source)
|
|
(define-key map (kbd "C-x C-e") #'flan-macroexpand--not-source)
|
|
(define-key map (kbd "C-c C-m") #'flan-macroexpand-again)
|
|
;; One-key aliases, as the break buffer has: this is a buffer you read with
|
|
;; one hand.
|
|
(define-key map (kbd "m") #'flan-macroexpand-again)
|
|
(define-key map (kbd "a") #'flan-macroexpand-all-again)
|
|
(define-key map (kbd "g") #'flan-macroexpand-refresh)
|
|
(define-key map (kbd "q") #'quit-window)
|
|
map)
|
|
"Keymap for `flan-macroexpansion-mode'.")
|
|
|
|
(define-derived-mode flan-macroexpansion-mode flan-mode "Flan-Macro"
|
|
"Mode for the buffer `flan-macroexpand' writes.
|
|
|
|
Derived from `flan-mode' because what is in it is Flan source and reading it
|
|
is the whole point: the indentation and the font-lock are the ones this
|
|
project already has. Read-only, and the three keys that would send its text
|
|
back to the daemon say why they will not.
|
|
|
|
\\{flan-macroexpansion-mode-map}"
|
|
(setq buffer-read-only t))
|
|
|
|
;;; What the program is made of, and what it is still holding
|
|
|
|
;; Two readings of one table. A dev build records the type at every
|
|
;; allocation — the allocator's caller knew it, and a Flan value carries no
|
|
;; header, so that is the only moment anything could — and this is that table
|
|
;; grouped by the name it wrote down.
|
|
;;
|
|
;; Biggest first, by bytes. Read in table order it is a list of everything
|
|
;; and answers nothing; read biggest-first it answers "where did the memory
|
|
;; go", which is the only reason either command exists.
|
|
|
|
(defcustom flan-allocations-buffer "*flan-allocations*"
|
|
"Where the allocation breakdown and the leak report are shown."
|
|
:type 'string)
|
|
|
|
(defun flan-allocations--show (op title)
|
|
"Ask the daemon for OP and show its rows under TITLE."
|
|
(let ((r (flan--request (list :op op))))
|
|
(unless (equal (plist-get r :status) "ok")
|
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))
|
|
(let ((rows (plist-get r :types))
|
|
(blocks (plist-get r :blocks))
|
|
(bytes (plist-get r :bytes)))
|
|
(with-current-buffer (get-buffer-create flan-allocations-buffer)
|
|
(let ((inhibit-read-only t))
|
|
(erase-buffer)
|
|
(special-mode)
|
|
(insert (propertize (format "%s\n" title) 'face 'bold))
|
|
(insert (propertize (format "%s\n\n" (or (plist-get r :note) ""))
|
|
'face 'font-lock-comment-face))
|
|
;; An overflowed table has blocks in the program that are in
|
|
;; nobody's row, so every number below it is a floor. Said before
|
|
;; the numbers, not after them, because a reader who missed it would
|
|
;; quote them as counts.
|
|
(when (plist-get r :overflow)
|
|
(insert (propertize
|
|
"the registry overflowed: these are floors, not counts\n\n"
|
|
'face 'warning)))
|
|
(if (null rows)
|
|
(insert "nothing recorded\n")
|
|
(insert (propertize (format "%8s %12s %s\n" "blocks" "bytes" "type")
|
|
'face 'shadow))
|
|
(dolist (row rows)
|
|
(insert (format "%8d %12d %s\n" (nth 1 row) (nth 2 row)
|
|
(nth 0 row))))
|
|
(insert (propertize
|
|
(format "\n%8s %12s in %d type%s\n" (or blocks 0)
|
|
(or bytes 0) (length rows)
|
|
(if (= (length rows) 1) "" "s"))
|
|
'face 'shadow))))
|
|
(goto-char (point-min)))
|
|
(display-buffer flan-allocations-buffer))))
|
|
|
|
;;;###autoload
|
|
(defun flan-allocations ()
|
|
"Every block the allocation registry recorded, grouped by type.
|
|
Live and dead both: in a long-running program the dead are the bulk of it, and
|
|
they are what says where the allocation went rather than only where it
|
|
stayed. A dev build only — a release build records nothing, and says so."
|
|
(interactive)
|
|
(flan-allocations--show "allocations" "Allocations, by type"))
|
|
|
|
;;;###autoload
|
|
(defun flan-leaks ()
|
|
"What the allocation registry is still holding live, grouped by type.
|
|
|
|
The same walk with the dead left out, and \"still holding\" means at the moment
|
|
you ask. There is no exit report to wait for: a program killed by a signal —
|
|
which is how a program under this editor usually ends — runs no handler at
|
|
all, so this command, asked whenever you like and including just before you
|
|
quit, is what answers for one. A program that returns from main on its own
|
|
can print the same breakdown to stderr under FLAN_DEV_LEAKS."
|
|
(interactive)
|
|
(flan-allocations--show "leaks" "Still held, by type"))
|
|
|
|
(provide 'flan)
|
|
;;; flan.el ends here
|