JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/emacs/flan-dev.el
Joseph Ferano fe858811cb An address answers with a type, and a killed program is asked rather than hooked 
The allocation registry had a recording side and half a reader. This is the
rest of the reader: point at any heap address, a breakdown by type, what is
still held, and the test that stops dev-ptr.flan's header from being read by
hand.

The recorded name, back to a type. The table records a string and has to —
the note is built where the concrete type exists and what crosses into the
runtime is bytes. What closes it is that the string is Types.to_string, which
is the source spelling, so the round trip is the language's own reader,
Parse.texpr and Check.resolve. No table of spellings is written down, so
nothing can fall behind Types.to_string, and a name that is not a type —
"pool slots" — is refused with the name quoted rather than defaulted.

The address root renders a (Ptr T) and not the pointee, which puts it through
render.ml's pointer arm: permission is asked in one place in the compiler, and
an address root and a slot root reach the same two answers by the same code.
Flan has no integer-to-pointer cast, so flan_dev_reg_addr is an extern beside
flan_agent_frame_slot, for the same reason.

One walk and two questions: a leak report is a breakdown with the dead left
out, so flan_dev_reg_by_type is one function and the agent formats it.

"At exit" is not a hook. A program killed by a signal runs no handler, which
is how a game under the editor ends, so (:op "leaks") is the authoritative
reader and can be asked at any moment including the one before the kill. The
atexit hook is for the program that returns from main, is registered from
inside flan_dev_reg_enable rather than by a file-scope destructor so that a
release build does not grow a third not-free place, and is off unless
FLAN_DEV_LEAKS is set because the acceptance table reads stderr.

The memcheck half of item 6 is deliberately not here.
2026-09-13 15:27:31 +07:00

1737 lines
82 KiB
EmacsLisp
Raw Blame History

;;; flan-dev.el --- Talk to a running Flan program -*- lexical-binding: t; -*-
;; The editor half of Flan's dev loop. `flan dev program.flan' compiles the
;; program, launches it, and listens on .flan-dev.sock beside the source; this
;; connects to that socket and sends it forms. M-x flan-dev starts that
;; daemon from here and connects when it is serving, so the loop needs no
;; terminal — and M-x flan-dev-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-x C-e evaluates the expression before point *in the running program* and
;; shows its value. That is a different primitive from redefining a name:
;; there is nothing to install a body into, so the expression is wrapped in a
;; thunk the program runs at its next frame boundary. Only scalars, bool and
;; strings render so far — a Flan value carries no header, so a printer has to
;; be derived per type at compile time, and the ones that are not derived yet
;; say so rather than guessing.
;;; Code:
(require 'subr-x)
(require 'seq)
(require 'pcase)
(require 'pulse)
(require 'cl-lib)
(require 'xref)
(require 'eldoc)
(defgroup flan-dev nil
"Talking to a running Flan program."
:group 'flan
:prefix "flan-dev-")
(defcustom flan-dev-socket-name ".flan-dev.sock"
"Name of the socket `flan dev' listens on, looked for up from the buffer."
:type 'string)
(defcustom flan-dev-echo-result t
"Whether an accepted evaluation reports in the echo area.
Turning this off makes a successful evaluation indistinguishable from one
that quietly did nothing, which is why it is on."
:type 'boolean)
(defcustom flan-dev-names-shown 4
"How many installed names to name before falling back to counting them."
:type 'integer)
(defcustom flan-dev-output-buffer "*flan-output*"
"Buffer the running program's own output is appended to."
:type 'string)
(defvar flan-dev--connection nil
"The open connection, or nil.")
(defvar flan-dev--socket nil
"Path of the socket `flan-dev--connection' is connected to.")
(defvar flan-dev--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-dev--busy nil
"Non-nil while a request is waiting for its reply.
`flan-dev--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-dev--send (proc form)
"Send FORM to PROC as one framed message."
(let* ((payload (encode-coding-string (prin1-to-string form) 'utf-8 t)))
(process-send-string proc (format "%d\n%s" (length payload) payload))))
(defun flan-dev--take-reply (proc)
"Read one complete framed message out of PROC's buffer, or return nil.
Never waits. This is the half of `flan-dev--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-dev--extract-reply body-start n)))))))
(defun flan-dev--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."
(let* ((end (byte-to-position (+ (position-bytes body-start) n)))
(text (decode-coding-string
(encode-coding-string (buffer-substring-no-properties
body-start end)
'utf-8 t)
'utf-8))
(form (car (read-from-string text))))
(delete-region (point-min) end)
form))
(defun flan-dev--read-reply (proc)
"Block until PROC sends one complete framed message, and read it."
(with-current-buffer (process-buffer proc)
(let ((deadline (+ (float-time) 30)))
;; The header first: digits up to a newline.
(while (and (not (save-excursion (goto-char (point-min))
(re-search-forward "\\`\\([0-9]+\\)\n" nil t)))
(< (float-time) deadline))
(accept-process-output proc 0.05))
(goto-char (point-min))
(unless (re-search-forward "\\`\\([0-9]+\\)\n" nil t)
;; Deliberately not retried. If the daemon took the request and died
;; before replying, the evaluation may well have happened — sending it
;; again would install it twice, or run a side-effecting expression
;; twice. Reconnecting happens before a send, never after one.
(if (process-live-p proc)
(error "flan dev: no reply in 30s from %s"
(abbreviate-file-name (or flan-dev--socket "the daemon")))
(error
"flan dev: the daemon on %s closed the connection; not resent, because it may already have run"
(abbreviate-file-name (or flan-dev--socket "?")))))
(let* ((n (string-to-number (match-string 1)))
(body-start (point)))
(while (and (< (- (position-bytes (point-max)) (position-bytes body-start)) n)
(< (float-time) deadline))
(accept-process-output proc 0.05))
(flan-dev--extract-reply body-start n)))))
(defun flan-dev--append-output (text)
"Append TEXT, the running program's own output, to its buffer."
(when (and text (> (length text) 0))
(with-current-buffer (get-buffer-create flan-dev-output-buffer)
(let ((at-end (= (point) (point-max))))
(save-excursion
(goto-char (point-max))
(insert text))
;; Follow the tail only for someone who was already at it; a reader
;; scrolled back is reading something.
(when at-end (goto-char (point-max)))))))
;; 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-dev--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-dev-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-dev-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-dev--auto-break ()
"Show the break buffer, if the program is still stopped and it is safe to.
Runs from a timer, deliberately: `flan-dev--absorb' notices the stop in the
middle of reading a reply on the socket, with `flan-dev--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-dev--absorb' again, and the program may have been resumed in
between — so what matters is whether it is stopped *now*."
(when (and flan-dev--stopped
flan-dev-break-on-stop
(not flan-dev--busy)
(process-live-p flan-dev--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-dev-break-on-stop 'focus) (buffer-live-p buf))
(let ((win (get-buffer-window buf)))
(when win (select-window win)))))))))
(defun flan-dev--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-dev--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-dev--append-output (plist-get reply :output))
(let ((was flan-dev--stopped)
(now (and (plist-get reply :stopped)
(or (plist-get reply :condition) "a condition"))))
(setq flan-dev--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-dev--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-dev--auto-break))))
reply)
(defvar flan-dev-settle-hook nil
"Run before a request is sent, with the connection already open.
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.")
(defun flan-dev--request (form)
"Send FORM to the connected program and return its reply."
(let* ((proc (flan-dev--live-connection))
(flan-dev--busy t))
(run-hooks 'flan-dev-settle-hook)
(flan-dev--absorb (progn (flan-dev--send proc form)
(flan-dev--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-dev--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-dev-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-dev--timer nil
"The background poll, or nil.")
(defun flan-dev--poll ()
"Ask the daemon how the program is, if it is safe to ask right now."
(when (and (not flan-dev--busy)
(process-live-p flan-dev--connection))
(let ((proc flan-dev--connection)
(flan-dev--busy t))
(ignore-errors
;; `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-dev--send proc '(:op "describe"))
(flan-dev--absorb (flan-dev--read-reply proc))))))
(defun flan-dev--start-polling ()
"Begin watching for the program stopping."
(flan-dev--stop-polling)
(when flan-dev-poll-interval
(setq flan-dev--timer
(run-with-timer flan-dev-poll-interval flan-dev-poll-interval
#'flan-dev--poll))))
(defun flan-dev--stop-polling ()
"Stop watching."
(when flan-dev--timer (cancel-timer flan-dev--timer))
(setq flan-dev--timer nil))
;;; Connection
(defun flan-dev--find-socket ()
"Find the daemon's socket by walking up from the current buffer."
(let ((dir (locate-dominating-file
(or buffer-file-name default-directory)
flan-dev-socket-name)))
(and dir (expand-file-name flan-dev-socket-name dir))))
(defun flan-dev--open (socket)
"Open a connection to SOCKET and make it the current one."
(when (process-live-p flan-dev--connection)
(delete-process flan-dev--connection))
(let ((buf (get-buffer-create " *flan-dev*")))
;; Unibyte, because the framing counts bytes and this buffer is where they
;; are counted.
(with-current-buffer buf (erase-buffer) (set-buffer-multibyte nil))
(setq flan-dev--connection
(make-network-process
:name "flan-dev" :buffer buf :family 'local :service socket
:coding 'binary :noquery t))
(setq flan-dev--socket socket))
(setq flan-dev--stopped nil)
(flan-dev--start-polling)
(force-mode-line-update t)
flan-dev--connection)
;; A daemon restarted while Emacs was not looking is the ordinary case, not an
;; exceptional one: `flan dev' ends when its program does, and a program under
;; development exits all the time. So a dead connection is reopened on the
;; socket it was on rather than reported — but only *before* a request goes
;; out. Reconnecting after one has been sent and lost would be a retry, and a
;; retry of `eval-expr' runs the expression a second time.
(defun flan-dev--live-connection ()
"The open connection, reconnecting if the daemon has been restarted."
(unless (process-live-p flan-dev--connection)
(cond
((null flan-dev--socket)
(error "Not connected: M-x flan-dev to start a program, or M-x flan-connect"))
((not (file-exists-p flan-dev--socket))
(setq flan-dev--connection nil)
(force-mode-line-update t)
(error "flan dev: nothing is listening on %s; start `flan dev program.flan' again"
(abbreviate-file-name flan-dev--socket)))
(t
(condition-case err
(progn (flan-dev--open flan-dev--socket)
;; A restarted daemon is a rebuilt program: everything known
;; about its names was about the last one.
(flan-dev--forget-defs)
;; And asked again straight away. An empty cache is honest
;; but silent: eldoc would go quiet and M-. would fall through
;; to some other backend until the next install happened to
;; refill it. Safe to call from here — the connection is live
;; by now, so it does not come back through this function.
(ignore-errors (flan-dev-refresh-defs))
(message "flan dev: reconnected to %s"
(abbreviate-file-name flan-dev--socket)))
(error
(setq flan-dev--connection nil)
(force-mode-line-update t)
(error "flan dev: cannot reconnect to %s: %s"
(abbreviate-file-name flan-dev--socket)
(error-message-string err)))))))
flan-dev--connection)
;;;###autoload
(defun flan-connect (&optional socket)
"Connect to a `flan dev' daemon listening on SOCKET.
With no argument, look for `flan-dev-socket-name' up from this buffer."
(interactive
(list (or (flan-dev--find-socket)
(read-file-name "flan dev socket: "))))
(unless socket (user-error "No %s found above this buffer" flan-dev-socket-name))
(flan-dev--open socket)
(let ((r (flan-dev--request '(:op "describe"))))
(flan-dev-refresh-defs)
(message "flan dev: connected to %s (%d functions, %d globals)"
(abbreviate-file-name socket)
(length (plist-get r :fns)) (length (plist-get r :globals))))
flan-dev--connection)
(defun flan-disconnect ()
"Close the connection, which also ends the daemon and its program."
(interactive)
(when (process-live-p flan-dev--connection)
(ignore-errors (flan-dev--request '(:op "close")))
(delete-process flan-dev--connection))
(setq flan-dev--connection nil)
;; Forgotten, not kept: this was a deliberate disconnect, so the next
;; request should say so rather than quietly reopening what was just closed.
(setq flan-dev--socket nil)
(setq flan-dev--stopped nil)
(flan-dev--stop-polling)
(flan-dev--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-dev-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-dev-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."
:type 'string)
(defcustom flan-dev-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)
(defvar flan-dev--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-dev-restart-program' is.")
(defvar flan-dev--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.")
(defun flan-dev--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-dev--daemon)
(setq flan-dev--daemon 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-dev-daemon-buffer))))
(defun flan-dev--start-daemon (file socket)
"Start `flan dev' on FILE listening on SOCKET, and return the process."
(let ((buf (get-buffer-create flan-dev-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-dev-command)
(expand-file-name flan-dev-command)
flan-dev-command))
;; 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 (format "%s dev %s -s %s\n\n" cmd file socket)))
(setq default-directory (file-name-directory (expand-file-name file))))
(make-process
:name "flan-dev-daemon" :buffer buf
:command (list cmd "dev" file "-s" socket)
;; 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-dev--daemon-sentinel)))
(defun flan-dev--connect-when-ready (socket proc)
"Connect to SOCKET once PROC is serving it, or say why that never happened."
(let ((deadline (+ (float-time) flan-dev-start-timeout))
(done nil))
(while (not done)
(cond
((condition-case nil (progn (flan-dev--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-dev-daemon-buffer)
(user-error "flan dev: the daemon exited before it was ready; see %s"
flan-dev-daemon-buffer))
((> (float-time) deadline)
(display-buffer flan-dev-daemon-buffer)
(user-error "flan dev: no socket on %s after %ss; see %s"
(abbreviate-file-name socket) flan-dev-start-timeout
flan-dev-daemon-buffer))
(t (accept-process-output proc 0.05))))))
;;;###autoload
(defun flan-dev (file &optional socket)
"Start `flan dev' on FILE and connect to it when it is ready.
SOCKET defaults to `flan-dev-socket-name' beside FILE, which is where the
daemon puts it when it is not told otherwise.
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
;; The program last started, where there was one: a restart after a quit is
;; the common case, and it is rarely the buffer point happens to be in —
;; you quit from wherever you were reading when you decided to.
(list (read-file-name "flan dev: " nil flan-dev--file t
(and buffer-file-name
(string-suffix-p ".flan" buffer-file-name)
(file-name-nondirectory buffer-file-name)))))
(when (process-live-p flan-dev--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-dev--file "the running program"))
(abbreviate-file-name (expand-file-name file))))
(flan-dev-quit)
(user-error "flan dev: keeping %s"
(abbreviate-file-name
(or flan-dev--file "the running program"))))
(user-error "flan dev: already running on %s; M-x flan-dev-quit first"
(abbreviate-file-name (or flan-dev--socket "a socket")))))
(let* ((file (expand-file-name file))
(socket (or socket
(expand-file-name flan-dev-socket-name
(file-name-directory file)))))
(unless (file-exists-p file)
(user-error "flan dev: no such file: %s" file))
(setq flan-dev--file file)
(setq flan-dev--daemon (flan-dev--start-daemon file socket))
(flan-dev--connect-when-ready socket flan-dev--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-dev--request '(:op "describe"))))
(flan-dev-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-dev--daemon))
;;;###autoload
(defun flan-dev-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."
(interactive)
(unless (process-live-p flan-dev--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-dev--connection)
"; M-x flan-disconnect ends the one you are connected to"
"")))
(let ((proc flan-dev--daemon))
(when (process-live-p flan-dev--connection)
(ignore-errors (flan-dev--request '(:op "close")))
(delete-process flan-dev--connection))
(setq flan-dev--connection nil
flan-dev--socket nil
flan-dev--stopped nil)
(flan-dev--stop-polling)
(flan-dev--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-dev--daemon 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-dev--daemon nil)
(force-mode-line-update t)
(message "flan dev: stopped")))
;;;###autoload
(defun flan-dev-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-dev' then starts it again, on the same program."
(interactive)
(unless (process-live-p flan-dev--daemon)
(user-error "flan dev: no daemon started from Emacs to restart"))
(let ((file flan-dev--file)
(socket flan-dev--socket))
(flan-dev-quit) ; returns only once it is really gone
(flan-dev 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-dev-live-face '((t :inherit success))
"Face for the modeline indicator when a program is connected."
:group 'flan-dev)
(defface flan-dev-lost-face '((t :inherit warning))
"Face for the modeline indicator when the daemon has gone away."
:group 'flan-dev)
(defface flan-dev-stopped-face '((t :inherit error))
"Face for the modeline indicator when the program is stopped at a break."
:group 'flan-dev)
(defun flan-dev-state ()
"Whether a program is connected: `stopped', `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."
(cond ((and (process-live-p flan-dev--connection) flan-dev--stopped) 'stopped)
((process-live-p flan-dev--connection) 'live)
(flan-dev--socket 'lost)
(t 'off)))
(defun flan-dev-mode-line ()
"The Flan connection indicator, for `mode-line-misc-info'."
(when (derived-mode-p 'flan-mode 'flan-repl-mode)
(pcase (flan-dev-state)
;; 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-dev--stopped)
'face 'flan-dev-stopped-face
'help-echo
"Stopped on an unhandled condition; C-c C-b to choose a restart"))
('live (propertize " flan:live" 'face 'flan-dev-live-face
'help-echo (format "Connected to %s" flan-dev--socket)))
('lost (propertize " flan:lost" 'face 'flan-dev-lost-face
'help-echo
(format "%s has gone away; the next command reconnects"
flan-dev--socket)))
(_ (propertize " flan:off" 'face 'shadow
'help-echo "Not connected (C-c C-z)")))))
;; Installed buffer-locally by `flan-dev-setup', not globally. A global entry
;; would evaluate on every redisplay of every buffer in the session — dired,
;; eshell, everything — to return nil, for someone who may never open a .flan
;; file at all. The `derived-mode-p' guard above stays anyway: cheap, and it
;; keeps the function honest wherever it is called from.
;;; 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-dev--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-dev-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-dev--request (list :op "restart-at" :index index :name name))))
(if (equal (plist-get r :status) "ok")
(progn
;; Accepted, not resumed — see `flan-dev-restart'.
(setq flan-dev--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-dev-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-dev-restarts) nil t)))
(let ((r (flan-dev--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-dev--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-dev-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-dev--request '(:op "abort"))))
(if (equal (plist-get r :status) "ok")
(progn (setq flan-dev--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-dev-restarts ()
"The restart names the stopped program is offering, innermost first."
(let ((r (flan-dev--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-dev--request '(:op "break"))))
(unless (equal (plist-get r :status) "ok")
(user-error "flan: %s" (or (plist-get r :message) "refused")))
(unless flan-dev--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-dev--restart-candidates restarts unreachable))
(choice
(completing-read
(format "flan: stopped on %s%s — " flan-dev--stopped
(if restarts "" " (no restarts are active)"))
(append (mapcar #'car table) '("abort")) nil t))
(index (cdr (assoc choice table))))
(cond
((equal choice "abort") (flan-dev-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-dev-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-dev--request '(:op "describe")))
(display-buffer (get-buffer-create flan-dev-output-buffer)))
(defun flan-describe ()
"Report what the running program currently defines."
(interactive)
(let ((r (flan-dev--request '(:op "describe"))))
(message "flan dev: %s, %d functions, %d globals"
(if (plist-get r :alive) "running" "exited")
(length (plist-get r :fns)) (length (plist-get r :globals)))))
;;; Where an error is
;; A reply's :loc is "file:line:col", and the column is a *byte* offset into
;; the line: the reader walks the source a byte at a time (lib/reader.ml), and
;; OCaml strings are bytes. Emacs counts characters, so the same rule the
;; framing has applies here — one non-ASCII character earlier on the line puts
;; the marker as many columns to the right as that character has bytes. Going
;; through `byte-to-position' from the line's start is the whole fix, and
;; `forward-char' would also have walked into the next line on a column past
;; the end of a short one.
(defun flan-dev--parse-loc (loc)
"Split LOC, a \"file:line:col\" string, into (FILE LINE COL), or nil."
(when (and (stringp loc)
(string-match "\\`\\(.*\\):\\([0-9]+\\):\\([0-9]+\\)\\'" loc))
(list (match-string 1 loc)
(string-to-number (match-string 2 loc))
(string-to-number (match-string 3 loc)))))
(defun flan-dev--position (line col)
"Position of LINE and byte-column COL in the current buffer."
(save-excursion
(goto-char (point-min))
(forward-line (1- line))
(let* ((bol (point))
(eol (line-end-position))
(want (+ (position-bytes bol) (max 0 (1- col))))
(p (and (<= want (position-bytes eol)) (byte-to-position want))))
;; Clamped rather than trusted: a column past the end of the line is a
;; location for something the reader wanted and did not find, and
;; overshooting into the next line would point at innocent code.
(min (or p eol) eol))))
(defun flan-dev--wire-position (pos)
"POS as the (LINE COL) pair the daemon reads off a `:pause' field.
The inverse of `flan-dev--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-dev--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-dev--buffer-visiting (file)
"The live buffer visiting FILE, or nil.
Compared with `file-equal-p', so a symlinked or relative path still matches."
(seq-find (lambda (b)
(let ((n (buffer-local-value 'buffer-file-name b)))
(and n (file-exists-p file) (file-equal-p n file))))
(buffer-list)))
;;; Error overlays
;; An error is shown where it is rather than only in the echo area, because the
;; echo area is gone the moment you type and the location is the useful half of
;; the message.
;;
;; It is 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-dev-error-face
'((t :inherit error :underline (:style wave)))
"Face for the text an evaluation was rejected at."
:group 'flan-dev)
(defface flan-dev-error-message-face
'((t :inherit error :height 0.9))
"Face for the message shown beside a rejected form."
:group 'flan-dev)
(defun flan-dev--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-dev-error))
(overlays-in (point-min) (point-max)))))
(defun flan-dev-clear-errors (&optional buffer)
"Remove Flan error overlays from BUFFER, or from the current buffer."
(interactive)
(with-current-buffer (or buffer (current-buffer))
(remove-overlays (point-min) (point-max) 'flan-dev-error t)
;; 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-dev--clear-errors-on-command t)))
(defun flan-dev--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-dev-clear-errors))
(defun flan-dev--show-error (loc msg)
"Mark MSG at LOC, if LOC names a file some buffer is visiting.
Returns non-nil when it put an overlay somewhere."
(let ((parts (flan-dev--parse-loc loc)))
(when parts
(let ((buf (flan-dev--buffer-visiting (nth 0 parts))))
(when buf
(with-current-buffer buf
(flan-dev-clear-errors buf)
(let* ((beg (flan-dev--position (nth 1 parts) (nth 2 parts)))
(end (save-excursion (goto-char beg) (line-end-position)))
(ov (make-overlay beg end buf t nil)))
(overlay-put ov 'flan-dev-error t)
(overlay-put ov 'face 'flan-dev-error-face)
(overlay-put ov 'help-echo msg)
(overlay-put ov 'evaporate nil)
(overlay-put ov 'priority 100)
(overlay-put ov 'after-string
(propertize (concat " " msg)
'face 'flan-dev-error-message-face))
;; Local to this buffer, and installed only now that there is
;; something for it to remove.
(add-hook 'pre-command-hook
#'flan-dev--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)))))))
;;; 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-dev-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-dev)
(defun flan-dev--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-dev-pause))
(overlays-in (point-min) (point-max)))))
(defun flan-dev-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-dev-pause t))
(defun flan-dev--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-dev-clear-pause beg end)
(let ((ov (make-overlay beg end nil t nil)))
(overlay-put ov 'flan-dev-pause t)
(overlay-put ov 'face 'flan-dev-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-dev--defs nil
"What the running program defines: a list of (NAME KIND SIGNATURE LOC).
LOC is the empty string where the daemon has none to give.")
(defun flan-dev--forget-defs ()
"Drop what is known about the program's names."
(setq flan-dev--defs nil))
(defun flan-dev-refresh-defs ()
"Ask the running program what it defines, and remember it."
(interactive)
(setq flan-dev--defs (plist-get (flan-dev--request '(:op "defs")) :defs))
(when (called-interactively-p 'interactive)
(message "flan: %d names" (length flan-dev--defs)))
flan-dev--defs)
(defun flan-dev--lookup (name)
"The entry for NAME, or nil.
A name is looked up exactly first. Failing that, a buffer inside a package
writes `settle' for what the program calls `sim/settle' — the alias is applied
from the file's own package, which this end does not know — so a name that is
the tail of exactly one program name resolves to it. Exactly one: several is
ambiguous and resolving it by picking would be a guess about which function
you meant."
(or (assoc name flan-dev--defs)
(let ((tail (concat "/" name)))
(let ((hits (seq-filter (lambda (d) (string-suffix-p tail (car d)))
flan-dev--defs)))
(and (= 1 (length hits)) (car hits))))))
(defun flan-dev--ambiguous (name)
"The entries whose name ends in NAME, when there is more than one."
(let ((hits (seq-filter (lambda (d) (string-suffix-p (concat "/" name) (car d)))
flan-dev--defs)))
(and (> (length hits) 1) hits)))
;;; eldoc
(defun flan-dev--enclosing-head ()
"The symbol heading the innermost form point is inside, or nil."
(ignore-errors
(save-excursion
(let ((open (nth 1 (syntax-ppss))))
(when open
(goto-char (1+ open))
(and (looking-at "\\(?:\\sw\\|\\s_\\)+") (match-string-no-properties 0)))))))
(defun flan-dev-eldoc-function (callback &rest _)
"Give CALLBACK the signature of the name at point, from the running program.
Falls back to the form point is inside, which is what you want while typing
its arguments. Reads the cache only: eldoc runs on a timer and must not
block on a socket or signal."
(let* ((name (or (thing-at-point 'symbol t) (flan-dev--enclosing-head)))
(d (and name (flan-dev--lookup name))))
(when d
(funcall callback
(concat (propertize (nth 2 d) 'face 'font-lock-function-name-face)
(pcase (nth 1 d)
("fn" "")
(k (concat " " k))))
:thing (car d))
t)))
;;; Completion
(defun flan-dev-completion-at-point ()
"Complete the name at point against the running program's own names.
Nothing is offered when nothing is known — an empty table would look like
\"no such name\" rather than \"not connected\"."
(when flan-dev--defs
(let ((b (bounds-of-thing-at-point 'symbol)))
(when b
(list (car b) (cdr b)
(mapcar #'car flan-dev--defs)
:annotation-function
(lambda (n) (let ((d (assoc n flan-dev--defs)))
(and d (concat " " (nth 1 d)))))
:company-docsig
(lambda (n) (let ((d (assoc n flan-dev--defs))) (and d (nth 2 d))))
;; Not exclusive: dabbrev and the like still have something to
;; say about a name the program has not been told about yet.
:exclusive 'no)))))
;;; Finding a definition
;; An xref backend rather than a command of its own, so M-. and M-, are what
;; they always are. Its refusals are by name: the daemon has no location for a
;; global, and the prelude is a string in the compiler rather than a file, and
;; both of those must say so instead of opening an empty buffer.
(defun flan-dev-xref-backend ()
"The xref backend for a buffer with a running Flan program behind it."
(and flan-dev--defs 'flan))
(cl-defmethod xref-backend-identifier-at-point ((_backend (eql flan)))
(thing-at-point 'symbol t))
(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql flan)))
(mapcar #'car flan-dev--defs))
(cl-defmethod xref-backend-definitions ((_backend (eql flan)) identifier)
(let ((d (flan-dev--lookup identifier)))
(cond
((null d)
(if-let ((hits (flan-dev--ambiguous identifier)))
(user-error "flan: %s could be %s; write the one you mean"
identifier (string-join (mapcar #'car hits) " or "))
(user-error "flan: the running program defines no %s" identifier)))
((equal (nth 3 d) "")
;; Tast.global and Tast.extern carry no Loc, so there is nothing to go
;; to. Guessing by searching for "(defvar ticks" would find the wrong
;; one in a program of several files, which is worse than refusing.
(user-error "flan: %s is a %s, and the daemon reports no location for one"
(car d) (nth 1 d)))
(t
(let ((parts (flan-dev--parse-loc (nth 3 d))))
(cond
((null parts)
(user-error "flan: the daemon gave %s an unreadable location: %s"
(car d) (nth 3 d)))
((string-match-p "\\`<.*>\\'" (nth 0 parts))
;; The prelude is a string inside the compiler (lib/prelude.ml) and
;; names itself <prelude>; anything in angle brackets is a
;; placeholder the frontend made up, not a path.
(user-error "flan: %s is defined in %s, which is not a file on disk"
(car d) (nth 0 parts)))
((not (file-name-absolute-p (nth 0 parts)))
;; The daemon makes its own source path absolute, so anything
;; relative arriving here came from somewhere that did not, and the
;; directory it is relative to is the daemon's, not this one's.
(user-error "flan: %s is at %s, relative to a directory this end does not know"
(car d) (nth 0 parts)))
((not (file-exists-p (nth 0 parts)))
;; The prelude is a string inside the compiler (lib/prelude.ml), so
;; its location names a file nobody can visit.
(user-error "flan: %s is defined in %s, which is not a file on disk"
(car d) (nth 0 parts)))
(t
(list (xref-make
(nth 2 d)
(xref-make-file-location
(nth 0 parts) (nth 1 parts)
;; A byte column, like every other one the daemon sends, but
;; a top-level definition starts at column 1 and anything
;; indenting it is ASCII, so the two agree here.
(max 0 (1- (nth 2 parts)))))))))))))
;;; 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-dev--parse-loc loc)))
(unless parts (user-error "flan: unreadable location: %s" loc))
(find-file-other-window (nth 0 parts))
(goto-char (flan-dev--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-dev--parse-loc loc))))
(cond
;; 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-dev--defs)
nil t))))
(unless flan-dev--defs
(user-error "flan: nothing is known about any name; connect first (C-c C-z)"))
(when (process-live-p flan-dev--connection)
(ignore-errors (flan-dev-refresh-defs)))
(let ((d (flan-dev--lookup name)))
(unless d
(if-let ((hits (flan-dev--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)
;; 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-dev-setup ()
"Give this buffer eldoc, completion and M-. against the running program.
Installed from here rather than from `flan-mode', which must keep working for
someone editing Flan with no program running and this file never loaded."
(add-hook 'completion-at-point-functions #'flan-dev-completion-at-point nil t)
(add-hook 'xref-backend-functions #'flan-dev-xref-backend nil t)
;; Registered, not switched on. Contributing a source is this file's
;; business; whether eldoc runs at all is the user's, and turning it on for
;; someone who has `global-eldoc-mode' off is overruling a decision they made
;; on purpose. It is on by default, so this is what almost everyone gets.
(add-hook 'eldoc-documentation-functions #'flan-dev-eldoc-function nil t)
(unless (member '(:eval (flan-dev-mode-line)) mode-line-misc-info)
;; Appended rather than prepended: the least urgent thing in the line.
(setq-local mode-line-misc-info
(append mode-line-misc-info '((:eval (flan-dev-mode-line)))))))
(add-hook 'flan-mode-hook #'flan-dev-setup)
;; Buffers that were already in flan-mode when this file loaded: the client is
;; autoloaded on first use, so by the time it arrives the file being edited has
;; long since had its mode hooks run.
(dolist (b (buffer-list))
(with-current-buffer b
(when (derived-mode-p 'flan-mode) (flan-dev-setup))))
;;; Evaluating
;; An install that says nothing is indistinguishable from one that failed
;; silently, so every accepted evaluation reports what landed in the running
;; program and what it cost. The names come from the reply rather than from
;; what was typed: the daemon is the one that knows which of them it installed,
;; and a `defvar' the program already had is not among them.
(defun flan-dev--names-phrase (names fallback)
"NAMES as a phrase for the echo area, or FALLBACK when there are none.
Long lists are counted and then sampled: an echo area truncated in the middle
of the tenth name tells you neither how many there were nor which."
(cond
((null names) fallback)
((<= (length names) flan-dev-names-shown) (string-join names ", "))
(t (format "%d names (%s, …)" (length names)
(string-join (seq-take names flan-dev-names-shown) ", ")))))
(defun flan-dev--report (reply what)
"Report REPLY, describing WHAT was sent."
(if (equal (plist-get reply :status) "ok")
(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-dev-clear-errors)
;; ...and a name that was just installed should complete, and have a
;; signature, from this moment rather than from the next connect.
(when (or fns names) (ignore-errors (flan-dev-refresh-defs)))
(when flan-dev-echo-result
(cond
;; An expression's value, rendered inside the running program —
;; nothing was marshalled back, because nothing could be.
(value (message "=> %s" value))
;; The daemon accepted it and had nothing to send. Say so rather
;; than claiming an install that did not happen.
(note (message "flan: %s — %s"
(flan-dev--names-phrase names what) note))
(t
;; `:fns' are the bodies that were installed and `:names' is
;; everything the evaluation declared; a buffer of five functions
;; and two vars should not report as "five".
(message "flan: %s installed in %.0f ms%s"
(flan-dev--names-phrase fns what)
(or (plist-get reply :ms) 0)
(let ((vars (seq-difference names fns)))
(if vars (format " (also %s)"
(flan-dev--names-phrase vars ""))
"")))))))
;; The daemon reports where, so mark it there. This must not itself
;; signal: the error the caller is owed is the daemon's, and losing it to a
;; bad location would report the wrong thing entirely.
(let ((loc (plist-get reply :loc))
(msg (plist-get reply :message)))
(ignore-errors (flan-dev--show-error loc (or msg "rejected")))
(user-error "flan: %s%s" (or msg "rejected")
(if loc (format " (%s)" loc) "")))))
(defun flan-dev--eval (code what &optional start end 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 DISCUSS.md
§9."
(let ((reply
(flan-dev--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-dev--wire-position (car pause))))))))
(flan-dev--report reply what)
;; `flan-dev--report' signals on a rejection, so reaching here means it
;; landed. Flashing the text that was sent answers "which form did that
;; take?" — the question the echo area cannot, because point may be nowhere
;; near the defn `beginning-of-defun' actually found.
(when (and start end) (pulse-momentary-highlight-region start end))
;; 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-dev--show-pause (car pause) (cdr pause)))
((and start end) (flan-dev-clear-pause start end)))
reply))
(defun flan-dev--text (start end)
"The buffer text from START to END, on the line it is actually written on.
The daemon reads what it is sent starting at line 1, so a form taken from the
middle of a buffer comes back with a location relative to the *snippet* — and
an error overlay drawn from that sits on line 1 of the file, pointing at
whatever happens to be there. Leading newlines are the whole fix: the reader
skips them, and the line numbers in the reply are then the buffer's own. The
columns already were, because a top-level form starts at column 1."
(concat (make-string (1- (line-number-at-pos start)) ?\n)
(buffer-substring-no-properties start end)))
(defun flan-dev--defun-bounds ()
"Bounds of the top-level form containing or preceding point, as (START . END)."
(save-excursion
(end-of-defun)
(let ((end (point)))
(beginning-of-defun)
(cons (point) end))))
(defun flan-dev--defun-at-point ()
"The text of the top-level form containing or preceding point."
(let ((b (flan-dev--defun-bounds)))
(buffer-substring-no-properties (car b) (cdr b))))
(defun flan-dev--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))))
;;;###autoload
(defun flan-eval-defun (&optional arg)
"Recompile the top-level form at point and install it in the running program.
With a prefix ARG, 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."
(interactive "P")
(let* ((b (flan-dev--defun-bounds))
(pause (flan-dev--pause-bounds b arg)))
(flan-dev--eval (flan-dev--text (car b) (cdr b)) "form" (car b) (cdr b)
pause)))
;;;###autoload
(defun flan-eval-buffer ()
"Recompile every top-level form in this buffer and install them together.
One module, not one per form: a var and the function that uses it have to
arrive in the same load or the first refers to storage that does not exist."
(interactive)
(flan-dev--eval (buffer-substring-no-properties (point-min) (point-max))
(buffer-name))
;; `flan-dev--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-dev-clear-pause))
;;;###autoload
(defun flan-eval-last-sexp (&optional arg)
"Evaluate the expression before point in the running program and show it.
With a prefix ARG, stop at it instead: the expression is wrapped in a
`(pause)' before it is checked, so the thunk breaks where it stands and the
break loop gets the frame. A flag rather than a position, because the
expression sent *is* the target — and because this path sends a raw
substring, so buffer line numbers would not survive it anyway.
It does not stick, and cannot: a thunk is built and thrown away, so there is
no declaration for the mark to live in. Nothing is drawn in the buffer for
the same reason."
(interactive "P")
(let ((code (buffer-substring-no-properties
(save-excursion (backward-sexp) (point))
(point))))
(flan-dev--report
(flan-dev--request
(append
(list :op "eval-expr" :code code :file (or buffer-file-name "<buffer>"))
(when arg (list :pause t))))
"expression")))
;;;###autoload
(defun flan-eval-region (start end)
"Recompile the top-level forms between START and END."
(interactive "r")
(flan-dev--eval (flan-dev--text start end) "region" start end))
;;; 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-dev--defs))
nil t nil nil
(and (fboundp 'flan-current-defun-name)
(flan-current-defun-name))))
current-prefix-arg))
(when (process-live-p flan-dev--connection)
(ignore-errors (flan-dev-refresh-defs)))
(let* ((d (flan-dev--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-dev--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-dev--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-dev--defs))
nil t))))
(flan-disassemble name 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-dev--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-dev)
;;; flan-dev.el ends here
Reference in New Issue View Git Blame Copy Permalink