Joseph Ferano
41334b3a8f
The break buffer captioned every refused restart "below this evaluation", which is the wrong sentence at a trap: there is no transfer channel, nothing on the list can be taken, and there is no evaluation to abandon. The terminal listing had always said the two apart. The wire now does too — a bare ! line ahead of the entries, because a trap with no restarts at all still has to be able to say so, and because :abandon being nil means three different things. The boundary was also the first entry truncation dropped: snap_push walks innermost first, and the boundary is the outermost frame of the evaluation. A slot and a name's worth of bytes are kept back for it. flan_break_resume goes; nothing has called it since choices became positions, and NEXT.md already said there was no such function. eval_boundary is cleared between runs beside the two stacks that already were. And the note on a taken restart stops costing a second round trip: the agent answers ok abandon for the boundary, which is the end that knows. Nested boundaries are tested rather than argued: two evaluations, six restarts, and abandoning the inner leaves the outer with its own still on offer.
923 lines
46 KiB
EmacsLisp
923 lines
46 KiB
EmacsLisp
;;; flan-cnr.el --- What a stopped program is offering -*- 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.
|
|
|
|
;; `C-c C-b' is a `completing-read' over restart names. That is the whole UI
|
|
;; for the one moment the dev loop exists to make survivable, and it is thin in
|
|
;; a way that is worth being specific about: it shows the names and nothing
|
|
;; else — not the condition's fields, not where the error was, not what the
|
|
;; frame between here and the restart was doing — and it will happily let you
|
|
;; choose a name that cannot be invoked. This is the buffer that replaces it.
|
|
;;
|
|
;; Two sources, and they answer different questions.
|
|
;;
|
|
;; **SBCL** answers *what to put first*. `invoke-debugger' prints the
|
|
;; condition, then `show-restarts', and stops. The backtrace is a command you
|
|
;; type, not something it shows you. That ordering is a claim: the restarts
|
|
;; are the decision in front of you and the stack is the explanation for it,
|
|
;; and a debugger that opens with forty frames has buried the decision under
|
|
;; the explanation. So: condition, restarts, then the stack, and the stack's
|
|
;; locals folded away until asked for.
|
|
;;
|
|
;; `show-restarts' also numbers them and brackets the name — and omits the
|
|
;; bracket on a name already used further in. That device is not decoration.
|
|
;; A restart *typed by name* resolves to the innermost frame offering it, so a
|
|
;; second frame offering `retry' is real, is on the list, and cannot be named
|
|
;; from a prompt — spec-conditions.md §4, and `flan_find_restart' in the
|
|
;; runtime. Today's `completing-read' hides it: the list has `retry' twice,
|
|
;; picking either sends the string "retry", and the inner one runs. Here
|
|
;; every choice goes out by *number* (`restart-at', with the name as a
|
|
;; receipt), so a shadowed entry is drawn without its bracket and is still
|
|
;; takeable — the bracket says only what a typed name would reach.
|
|
;;
|
|
;; **CIDER's stacktrace buffer** answers *how it should behave*: frames that
|
|
;; expand in place, TAB to fold, everything reachable from the keyboard,
|
|
;; `q' to go. What was not taken from it is the cause chain — CIDER walks
|
|
;; `ex-cause' because a JVM exception wraps another one, and a Flan condition
|
|
;; wraps nothing — and its filters, which exist because a JVM backtrace is
|
|
;; mostly frames nobody wrote.
|
|
;;
|
|
;; Everything this buffer cannot fill in is drawn as a section that says so, by
|
|
;; name, with what it would take. A missing section is indistinguishable from
|
|
;; a section that happened to be empty, and only one of those is a fact about
|
|
;; the program.
|
|
|
|
;;; Code:
|
|
|
|
(require 'seq)
|
|
(require 'subr-x)
|
|
|
|
(declare-function flan--request "flan" (form))
|
|
(declare-function flan-inspect "flan-inspect" (expr))
|
|
(declare-function flan-inspect-slot "flan-inspect" (frame slot name))
|
|
|
|
(defgroup flan-cnr nil
|
|
"The conditions and restarts buffer."
|
|
:prefix "flan-cnr-"
|
|
:group 'flan)
|
|
|
|
(defcustom flan-cnr-buffer "*flan-conditions*"
|
|
"Where the break buffer draws."
|
|
:type 'string)
|
|
|
|
(defvar flan-cnr-request-function #'flan--request
|
|
"How this buffer reaches the daemon.
|
|
One plist in, the reply plist out. A variable so the renderers can be driven
|
|
from fixtures, and so `flan.el' is named in one place.")
|
|
|
|
;;; What is not available, and why
|
|
|
|
;; Said in one table rather than at each use, so a section's reason is
|
|
;; revisable in one place. One short sentence each: these print in the
|
|
;; buffer, and the buffer is not the place for design notes.
|
|
|
|
(defconst flan-cnr-unavailable
|
|
'((layout
|
|
. "no struct has this name; a trap's name has no fields behind it")
|
|
(stack
|
|
. "the program is running; ask again once it stops")
|
|
(locals
|
|
. "this frame has no named locals")
|
|
(globals
|
|
. "no frame on this stack reads a global; its state is all in its locals"))
|
|
"Why a section of this buffer is empty, by name.")
|
|
|
|
(defun flan-cnr--why (key)
|
|
(or (cdr (assq key flan-cnr-unavailable)) "not implemented"))
|
|
|
|
;;; Restarts, and which of them can actually be chosen
|
|
|
|
(defun flan-cnr-annotate-restarts (names &optional unreachable abandon trap)
|
|
"Turn NAMES — innermost first — into what the buffer draws.
|
|
Each entry is (INDEX NAME SHADOWED-BY KIND), where SHADOWED-BY is the index of
|
|
the earlier entry that owns the name, or nil, and KIND is one of nil,
|
|
`unreachable', `trapped' or `abandon'.
|
|
|
|
Shadowing is §4's walk, computed here because it can be: `restart NAME'
|
|
resolves through `flan_find_restart', which returns the first frame whose hash
|
|
matches, so a name's second appearance is unreachable through the only verb
|
|
there is. Nothing new has to be asked of the program to know that — the order
|
|
of the list already says it.
|
|
|
|
The rest come off the reply, because nothing here can work them out.
|
|
UNREACHABLE is the positions the program will refuse. ABANDON is the position
|
|
that drops the evaluation, and it is a position rather than a name on purpose —
|
|
a program may establish a restart called `abandon-evaluation' of its own, and
|
|
only the agent knows which frame is really the boundary.
|
|
|
|
TRAP says *why* they are refused, which is a different question from which they
|
|
are. A break taken by a trap — a segfault, a null allocator — has no transfer
|
|
channel at all: every restart on it is refused, the boundary included, and
|
|
there is no evaluation to abandon your way out of. Captioning those rows
|
|
\"below this evaluation\" would send someone looking for an evaluation that is
|
|
not there, so the two refusals are drawn apart. It cannot be inferred from
|
|
ABANDON being nil: a break the program took on its own has a nil there too, and
|
|
so does a list long enough to have been truncated."
|
|
(let ((seen nil) (i -1))
|
|
(mapcar (lambda (name)
|
|
(setq i (1+ i))
|
|
(let ((owner (cdr (assoc name seen))))
|
|
(unless owner (push (cons name i) seen))
|
|
(list i name owner
|
|
(cond (trap 'trapped)
|
|
((eql i abandon) 'abandon)
|
|
((memq i unreachable) 'unreachable)))))
|
|
names)))
|
|
|
|
;;; Drawing
|
|
|
|
(defvar-local flan-cnr--state nil
|
|
"The plist this buffer was last drawn from.")
|
|
(defvar-local flan-cnr--open nil
|
|
"Indices of the frames whose locals are showing.")
|
|
|
|
(defun flan-cnr--unavailable (key)
|
|
(propertize (concat " not available — " (flan-cnr--why key) "\n")
|
|
'face 'font-lock-comment-face))
|
|
|
|
(defun flan-cnr--section (title)
|
|
(insert (propertize (format "--- %s\n" title) 'face 'font-lock-comment-face)))
|
|
|
|
(defconst flan-cnr-breakpoint "Pause"
|
|
"The condition `(pause)' signals.
|
|
`lib/prelude.ml' writes it as an ordinary struct under a `restart-case', so
|
|
nothing in the compiler knows a breakpoint from an error and this buffer is the
|
|
first place that can tell the difference. Named here rather than spelled at
|
|
its use, because it is a fact about the prelude.")
|
|
|
|
(defun flan-cnr--headline-fields (fields)
|
|
"The condition's own numbers, folded into the headline.
|
|
FIELDS is the fields list; the result is \"low 9, high 9, length 4\" over the
|
|
fields whose values arrived and are short enough to read inline, or nil.
|
|
Generic on purpose: the fields are the condition's own, so BoundsError reads
|
|
as its numbers and every other condition reads as its own."
|
|
(let ((short (seq-filter (lambda (f)
|
|
(and (nth 2 f) (<= (length (nth 2 f)) 24)
|
|
(not (string-match-p "\n" (nth 2 f)))))
|
|
fields)))
|
|
(when short
|
|
(concat (mapconcat (lambda (f) (format "%s %s" (nth 0 f) (nth 2 f)))
|
|
(seq-take short 4) ", ")
|
|
;; A headline is one line, so a wide condition is cut — and
|
|
;; says it is, because a silently short list reads as the whole
|
|
;; of what the condition carries. The section below has all of
|
|
;; them.
|
|
(when (> (length short) 4) ", …")))))
|
|
|
|
(defun flan-cnr--site-line-col (site)
|
|
"The (LINE . COL) a SITE string names, or nil."
|
|
(when (and site (string-match ":\\([0-9]+\\):\\([0-9]+\\)\\'" site))
|
|
(cons (string-to-number (match-string 1 site))
|
|
(string-to-number (match-string 2 site)))))
|
|
|
|
(defun flan-cnr--insert-site (state)
|
|
"Where the expression that trapped is written, with the line and a caret.
|
|
The frame lines below say where each call was; this is the only record of the
|
|
indexing or the division itself, so it sits directly under the headline."
|
|
(let ((site (plist-get state :site)))
|
|
(when site
|
|
(insert (propertize (format "at %s\n" site) 'face 'shadow))
|
|
(let ((source (plist-get state :source))
|
|
(lc (flan-cnr--site-line-col site)))
|
|
(when (and source lc)
|
|
(let* ((prefix (format "%4d| " (car lc)))
|
|
(col (max 0 (1- (cdr lc))))
|
|
;; The pad copies the source's own leading whitespace rather
|
|
;; than assuming spaces: a tab-indented line puts the caret
|
|
;; a tab-stop off under any other rule, and a caret that
|
|
;; points at the wrong column is worse than none.
|
|
(pad (concat (make-string (length prefix) ?\s)
|
|
(mapconcat
|
|
(lambda (ch) (if (eq ch ?\t) "\t" " "))
|
|
(string-to-list (substring source 0
|
|
(min col (length source))))
|
|
""))))
|
|
(insert "\n" (propertize prefix 'face 'shadow) source "\n")
|
|
(insert pad (propertize "^" 'face 'error) "\n")))))))
|
|
|
|
(defun flan-cnr--insert-condition (state)
|
|
(let* ((name (or (plist-get state :condition) "a condition"))
|
|
;; A breakpoint is a stop, not a failure. Everything underneath is
|
|
;; identical — `(pause)' *is* `error' under a `restart-case', which is
|
|
;; what a breakpoint is in a language that has conditions — so the
|
|
;; only thing that can be wrong here is the word for it. Calling a
|
|
;; breakpoint unhandled would be a small lie told at the top of the
|
|
;; one buffer that exists to say what happened.
|
|
(paused (equal name flan-cnr-breakpoint))
|
|
(numbers (flan-cnr--headline-fields (plist-get state :fields))))
|
|
(insert (propertize name 'face (if paused 'warning 'error)))
|
|
(when numbers (insert " — " numbers))
|
|
(insert "\n")
|
|
(insert (propertize
|
|
(if paused
|
|
"stopped at (pause); nothing has been unwound\n"
|
|
"unhandled; stopped where it erred, nothing unwound\n")
|
|
'face 'shadow))
|
|
(flan-cnr--insert-site state))
|
|
(insert "\n")
|
|
(flan-cnr--section "Condition fields:")
|
|
;; The shape and the values are two answers. The shape — names and types —
|
|
;; is the daemon's own, out of the build it holds; the values are read out
|
|
;; of the stopped program by a thunk the daemon builds. So a field can be
|
|
;; named and typed while its value is missing, and the row says why in one
|
|
;; sentence rather than being left off.
|
|
(let ((fields (plist-get state :fields))
|
|
(why (plist-get state :fields-why)))
|
|
(if (null fields)
|
|
;; Three different empties, and only one of them is a refusal. A
|
|
;; condition that *declares* no fields is an ordinary thing — Pause is
|
|
;; one — and saying "no struct has this name" about it would be
|
|
;; false. `:fields-empty' is the daemon's own count, so this end is
|
|
;; not inferring it from a list that is also empty when the read
|
|
;; failed.
|
|
(insert (propertize
|
|
(cond
|
|
((plist-get state :fields-empty)
|
|
" this condition has no fields\n")
|
|
(t (concat " not available — "
|
|
(or why (flan-cnr--why 'layout)) "\n")))
|
|
'face 'font-lock-comment-face))
|
|
(progn
|
|
;; The section-wide reason, once, above the rows — repeating it per
|
|
;; field was the noise the rewording pass was asked to cut.
|
|
(when why
|
|
(insert (propertize (concat " not read — " why "\n")
|
|
'face 'font-lock-comment-face)))
|
|
(let ((w (apply #'max 4 (mapcar (lambda (f) (length (nth 0 f))) fields)))
|
|
(tw (apply #'max 4 (mapcar (lambda (f) (length (or (nth 1 f) ""))) fields))))
|
|
(dolist (f fields)
|
|
(let ((start (point))
|
|
(name (nth 0 f)) (type (or (nth 1 f) "?")) (value (nth 2 f)))
|
|
(insert (format " :%s%s %s%s " name
|
|
(make-string (- w (length name)) ?\s)
|
|
(propertize type 'face 'font-lock-type-face)
|
|
(make-string (- tw (length type)) ?\s)))
|
|
(insert (if value value
|
|
;; A field-specific reason — no printer for its type —
|
|
;; is that row's own; a bare "not read" defers to the
|
|
;; sentence above.
|
|
(propertize
|
|
(if (nth 3 f) (concat "not read — " (nth 3 f))
|
|
"not read")
|
|
'face 'font-lock-comment-face))
|
|
"\n")
|
|
(add-text-properties start (point)
|
|
(list 'flan-cnr-inspect nil
|
|
'mouse-face 'highlight))))))))
|
|
(insert "\n"))
|
|
|
|
(defun flan-cnr--insert-restarts (state)
|
|
(flan-cnr--section "Restarts (innermost first) — RET or a digit takes one:")
|
|
(let* ((names (plist-get state :restarts))
|
|
(rows (flan-cnr-annotate-restarts names
|
|
(plist-get state :unreachable)
|
|
(plist-get state :abandon)
|
|
(plist-get state :trap))))
|
|
(if (null rows)
|
|
(insert (propertize
|
|
" none are active. Nothing between the error and the top offered one; abort, or fix a body and reload\n"
|
|
'face 'font-lock-comment-face))
|
|
(let ((w (apply #'max 4 (mapcar (lambda (r) (length (nth 1 r))) rows))))
|
|
(dolist (r rows)
|
|
(let* ((i (nth 0 r)) (name (nth 1 r)) (owner (nth 2 r))
|
|
(kind (nth 3 r))
|
|
(start (point)))
|
|
;; SBCL's bracket: it is there when the name reaches this frame and
|
|
;; gone when it does not. A shadowed entry is still takeable — the
|
|
;; choice goes out by number, not by name — so the missing bracket
|
|
;; says only that typing the name at a prompt would reach the
|
|
;; inner one. A row the program will refuse loses the bracket for
|
|
;; a different reason, and says which in its own words.
|
|
(insert (format " %2d: %s%s%s " i
|
|
(if (or owner (memq kind '(unreachable trapped)))
|
|
" " "[")
|
|
(propertize name 'face
|
|
(cond ((memq kind '(unreachable trapped))
|
|
'shadow)
|
|
((eq kind 'abandon) 'warning)
|
|
(owner 'shadow)
|
|
(t 'font-lock-keyword-face)))
|
|
(if (or owner (memq kind '(unreachable trapped)))
|
|
" " "]")))
|
|
(insert (make-string (- w (length name)) ?\s))
|
|
(cond
|
|
;; What the reader wants nine times in ten after a C-x C-e went
|
|
;; wrong, so it says what it does *and* what it does not: nothing
|
|
;; here can undo the part of the expression that already ran.
|
|
((eq kind 'abandon)
|
|
(insert (propertize
|
|
"stop running this expression and carry on; what it already changed stays changed"
|
|
'face 'font-lock-comment-face)))
|
|
;; Shown rather than hidden, because "where did my restart go" is
|
|
;; a fair question — and taking it says why instead of nothing,
|
|
;; which is how this went wrong the first time.
|
|
((eq kind 'unreachable)
|
|
(insert (propertize
|
|
"below this evaluation; a transfer to it has nowhere to land"
|
|
'face 'shadow)))
|
|
;; The other refusal, and it is not the same one. A trap has no
|
|
;; transfer channel anywhere in the call, so nothing on this list
|
|
;; can be taken — there is no evaluation to be below, and none to
|
|
;; abandon. Fixing the body and reloading is the way out.
|
|
((eq kind 'trapped)
|
|
(insert (propertize
|
|
"the trap has no transfer channel; nothing here can be resumed into"
|
|
'face 'shadow)))
|
|
(owner
|
|
(insert (propertize
|
|
(format "same name as %d; taken by its number" owner)
|
|
'face 'shadow))))
|
|
(insert "\n")
|
|
(add-text-properties start (point)
|
|
(list 'flan-cnr-restart name
|
|
'flan-cnr-shadowed owner
|
|
'flan-cnr-kind kind
|
|
'flan-cnr-index i
|
|
'mouse-face 'highlight))))))
|
|
;; Last, and on the same list, because it is the same decision: what you
|
|
;; pick when none of the restarts is the answer.
|
|
(let ((start (point)))
|
|
(insert (format " %2d: [%s] " (length rows)
|
|
(propertize "abort" 'face 'error)))
|
|
(insert (propertize "end the program here; the dev session ends with it\n"
|
|
'face 'shadow))
|
|
(add-text-properties start (point)
|
|
(list 'flan-cnr-abort t 'mouse-face 'highlight))))
|
|
(insert "\n"))
|
|
|
|
(defun flan-cnr--insert-stack (state)
|
|
(flan-cnr--section "Stack (innermost first) — TAB folds a frame's locals:")
|
|
(let ((frames (plist-get state :stack)))
|
|
(if (null frames)
|
|
(insert (flan-cnr--unavailable 'stack))
|
|
(let ((i -1))
|
|
(dolist (fr frames)
|
|
(setq i (1+ i))
|
|
(let ((start (point))
|
|
(open (memq i flan-cnr--open)))
|
|
(insert (format " %2d: %s %s%s\n" i
|
|
(if open "v" ">")
|
|
(propertize (or (plist-get fr :fn) "?")
|
|
'face 'font-lock-function-name-face)
|
|
(if (plist-get fr :loc)
|
|
(propertize (format " %s" (plist-get fr :loc))
|
|
'face 'shadow)
|
|
"")))
|
|
(add-text-properties start (point)
|
|
(list 'flan-cnr-frame i 'mouse-face 'highlight)))
|
|
;; Collapsed by default. A stopped program has as many locals as it
|
|
;; has frames, and all of them at once is the backtrace problem again
|
|
;; one level down.
|
|
(when (memq i flan-cnr--open)
|
|
(let ((locals (plist-get fr :locals)))
|
|
(dolist (r (plist-get fr :refused))
|
|
(insert (format " %s%s\n"
|
|
(if (string-empty-p (nth 0 r)) ""
|
|
(propertize (format "%s: " (nth 0 r))
|
|
'face 'shadow))
|
|
(propertize (nth 1 r) 'face 'shadow))))
|
|
(if (null locals)
|
|
(unless (plist-get fr :refused)
|
|
(insert (flan-cnr--unavailable 'locals)))
|
|
(dolist (l locals)
|
|
(let ((start (point)))
|
|
(insert (format " %s %s = %s\n"
|
|
(propertize (nth 1 l) 'face 'font-lock-type-face)
|
|
(nth 0 l) (nth 2 l)))
|
|
;; The slot's *index*, which is the fourth element the
|
|
;; `locals\=' reply now puts on each line, and not its name.
|
|
;; A name does not identify a slot: two slots of one frame
|
|
;; can share one, and a refused slot is absent from this
|
|
;; list, so the position in it is not an identifier
|
|
;; either. Sending the name is precisely the old bug —
|
|
;; the name was evaluated as an expression wherever the
|
|
;; evaluator stood, which is the right frame only when
|
|
;; this is the innermost one.
|
|
(add-text-properties
|
|
start (point)
|
|
(list 'flan-cnr-inspect (list :slot i (nth 3 l) (nth 0 l))
|
|
'mouse-face 'highlight)))))))))))
|
|
(insert "\n"))
|
|
|
|
(defun flan-cnr--insert-globals (state)
|
|
"Draw the globals the stopped stack reaches.
|
|
|
|
One section rather than a fold under each frame, and that is the design rather
|
|
than a layout choice. A global is not part of a frame — it is program state
|
|
the frame happened to touch — so nesting it under one implies an ownership that
|
|
is not there, and repeats the name once per frame that reads it.
|
|
|
|
What recovers the useful half of per-frame nesting is the annotation: each
|
|
entry says which frames touch it, by the same index the stack section numbers
|
|
them with. \"the whole chain is reading this\" and \"only the innermost is\"
|
|
are different facts and they read differently here.
|
|
|
|
The order is the daemon's, and it is by the innermost frame that touches each
|
|
one: a deep stack makes the union large, and proximity to the error is what
|
|
puts the likely culprit on top."
|
|
(flan-cnr--section "Globals this stack reaches — innermost frame first:")
|
|
(let ((globals (plist-get state :globals))
|
|
(refused (plist-get state :globals-refused))
|
|
(skipped (plist-get state :globals-skipped)))
|
|
(if (and (null globals) (null refused) (null skipped))
|
|
(insert (flan-cnr--unavailable 'globals))
|
|
(let ((w (apply #'max 1 (mapcar (lambda (g) (length (nth 0 g))) globals))))
|
|
(dolist (g globals)
|
|
(let ((start (point))
|
|
(frames (nth 3 g)))
|
|
(insert (format " %s%s %s = %s"
|
|
(nth 0 g)
|
|
(make-string (- w (length (nth 0 g))) ?\s)
|
|
(propertize (nth 1 g) 'face 'font-lock-type-face)
|
|
(nth 2 g)))
|
|
;; No frames at all should not be reachable — the daemon chooses
|
|
;; these *by* the frames that touch them — but "frame" followed by
|
|
;; nothing would be the one shape here that reads as a bug in the
|
|
;; program rather than in this line, so it says so instead.
|
|
(insert (propertize
|
|
(if (null frames) " (no frame recorded)\n"
|
|
(format " %s %s\n"
|
|
(if (cdr frames) "frames" "frame")
|
|
(mapconcat #'number-to-string frames ", ")))
|
|
'face 'shadow))
|
|
;; The same property the locals lines carry, so `i' reaches a
|
|
;; global exactly as it reaches a local: a global *is* an
|
|
;; expression in the source, which is what the inspector needs.
|
|
(add-text-properties start (point)
|
|
(list 'flan-cnr-inspect (list :expr (nth 0 g))
|
|
'mouse-face 'highlight)))))
|
|
(dolist (r refused)
|
|
(insert (format " %s%s\n"
|
|
(if (string-empty-p (nth 0 r)) ""
|
|
(propertize (format "%s: " (nth 0 r)) 'face 'shadow))
|
|
(propertize (nth 1 r) 'face 'shadow))))
|
|
;; A frame the daemon could not attribute means the union above is not
|
|
;; the whole union. Said, rather than left to look like a complete
|
|
;; answer with fewer entries in it.
|
|
(when skipped
|
|
(insert (propertize
|
|
" the union is incomplete; these frames could not be attributed:\n"
|
|
'face 'font-lock-warning-face))
|
|
(dolist (s skipped)
|
|
(insert (propertize (format " %s — %s\n" (nth 0 s) (nth 1 s))
|
|
'face 'shadow))))))
|
|
(insert "\n"))
|
|
|
|
(defun flan-cnr--render (state)
|
|
"Draw STATE, a plist, into the current buffer."
|
|
(let ((inhibit-read-only t))
|
|
(erase-buffer)
|
|
(setq flan-cnr--state state)
|
|
;; SBCL's order: what happened, what you can do about it, then why.
|
|
(flan-cnr--insert-condition state)
|
|
(flan-cnr--insert-restarts state)
|
|
(flan-cnr--insert-stack state)
|
|
;; After the stack, because it is scoped *by* the stack: the frame numbers
|
|
;; an entry is annotated with have to be on screen above it to read.
|
|
(flan-cnr--insert-globals state)
|
|
(insert (propertize
|
|
"RET/0-9 take a abort TAB fold a frame i inspect g refresh q quit\n"
|
|
'face 'shadow))
|
|
(goto-char (point-min))
|
|
;; Point starts on the restart that abandons the evaluation, when there is
|
|
;; one. Not a reordering of the list — the number beside a restart is the
|
|
;; program's index and moving rows would make the numbers lie — but this is
|
|
;; what a reader wants nine times in ten after a C-x C-e went wrong, and
|
|
;; RET should land on it rather than on the top of the buffer.
|
|
(when (plist-get state :abandon)
|
|
(let ((found nil))
|
|
(while (and (not found) (not (eobp)))
|
|
(if (eq (get-text-property (point) 'flan-cnr-kind) 'abandon)
|
|
(setq found t)
|
|
(forward-line 1)))
|
|
(unless found (goto-char (point-min)))))))
|
|
|
|
;;; Commands
|
|
|
|
(defun flan-cnr-take ()
|
|
"Take the restart on this line."
|
|
(interactive)
|
|
(cond
|
|
((get-text-property (point) 'flan-cnr-abort) (flan-cnr-abort))
|
|
;; Refused here, with the reason, rather than sent and refused there. Both
|
|
;; answers are the same sentence; this one arrives without a round trip, and
|
|
;; either way something is *said* — a choice that quietly does nothing is
|
|
;; the defect this whole line exists to close.
|
|
;;
|
|
;; Two refusals, because there are two reasons and the wrong one is worse
|
|
;; than none: a segfault's break is not inside an evaluation, and telling
|
|
;; someone to abandon one sends them looking for something that is not
|
|
;; there.
|
|
((eq (get-text-property (point) 'flan-cnr-kind) 'trapped)
|
|
(user-error
|
|
"flan: this break was taken by a trap with no transfer channel, so no restart can be taken from it. Read the frame, then fix a body and reload, or abort"))
|
|
((eq (get-text-property (point) 'flan-cnr-kind) 'unreachable)
|
|
(user-error
|
|
"flan: restart %d is below the evaluation this break is inside, so a transfer to it has nowhere to land. Take one offered above it, or abandon the evaluation"
|
|
(get-text-property (point) 'flan-cnr-index)))
|
|
((get-text-property (point) 'flan-cnr-restart)
|
|
(flan-cnr--invoke (get-text-property (point) 'flan-cnr-index)
|
|
(get-text-property (point) 'flan-cnr-restart)))
|
|
((get-text-property (point) 'flan-cnr-frame) (flan-cnr-toggle-frame))
|
|
(t (user-error "flan: nothing to take on this line"))))
|
|
|
|
(defun flan-cnr--invoke (index name)
|
|
"Take restart INDEX, named NAME.
|
|
By index, because the index is the identity — two frames can offer `retry'
|
|
and only one of them is the one on this line. The name rides along as a
|
|
receipt: the daemon checks it against what the program has at that index and
|
|
refuses if the two have drifted apart, so a stale buffer cannot take a
|
|
different restart than the one it showed."
|
|
(let ((r (funcall flan-cnr-request-function
|
|
(list :op "restart-at" :index index :name name))))
|
|
(if (equal (plist-get r :status) "ok")
|
|
;; Accepted, not resumed — the choice is validated against the stopped
|
|
;; stack and taken when that thread next comes round its loop. So the
|
|
;; buffer says so and goes, rather than redrawing a state that is about
|
|
;; to stop being true.
|
|
(progn (message "flan: %s — %s" name (or (plist-get r :note) "accepted"))
|
|
(quit-window))
|
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))))
|
|
|
|
(defun flan-cnr-take-number (n)
|
|
"Take restart number N, as SBCL's debugger does."
|
|
(interactive (list (- last-command-event ?0)))
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(let ((found nil))
|
|
(while (and (not found) (not (eobp)))
|
|
(when (and (equal n (get-text-property (point) 'flan-cnr-index))
|
|
(or (get-text-property (point) 'flan-cnr-restart)
|
|
(get-text-property (point) 'flan-cnr-shadowed)))
|
|
(setq found t))
|
|
(unless found (forward-line 1)))
|
|
(if found (flan-cnr-take)
|
|
;; The abort line's number is one past the last restart.
|
|
(let ((names (plist-get flan-cnr--state :restarts)))
|
|
(if (= n (length names)) (flan-cnr-abort)
|
|
(user-error "flan: there is no restart %d" n)))))))
|
|
|
|
(defun flan-cnr-abort ()
|
|
"Let the stopped program die where it stopped."
|
|
(interactive)
|
|
(let ((r (funcall flan-cnr-request-function '(:op "abort"))))
|
|
(if (equal (plist-get r :status) "ok")
|
|
(progn (message "flan: %s" (or (plist-get r :note) "aborted")) (quit-window))
|
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))))
|
|
|
|
(defun flan-cnr-toggle-frame ()
|
|
"Show or hide this frame's locals."
|
|
(interactive)
|
|
(let ((i (get-text-property (point) 'flan-cnr-frame)))
|
|
(unless i (user-error "flan: point is not on a frame"))
|
|
(setq flan-cnr--open
|
|
(if (memq i flan-cnr--open) (delq i flan-cnr--open)
|
|
(cons i flan-cnr--open)))
|
|
;; Fetched on first open and then kept: a frame's locals cannot change
|
|
;; while the program is stopped, and re-asking on every fold would put a
|
|
;; round trip behind a keystroke that looks like pure redrawing.
|
|
;; Only when there is something to ask. The fixture tests render this
|
|
;; buffer from a literal state with no socket behind it and no `flan'
|
|
;; loaded, and folding a frame must stay a display operation there — the
|
|
;; renderer already draws a reason for a frame whose locals are nil, which
|
|
;; is the same degradation every other section of this buffer uses.
|
|
(when (and (memq i flan-cnr--open)
|
|
(functionp flan-cnr-request-function))
|
|
(let ((fr (nth i (plist-get flan-cnr--state :stack))))
|
|
(when (and fr (not (plist-get fr :fetched)))
|
|
(let ((answer (flan-cnr-locals i)))
|
|
(setcar (nthcdr i (plist-get flan-cnr--state :stack))
|
|
(plist-put (plist-put (plist-put fr :locals (nth 0 answer))
|
|
:refused (nth 1 answer))
|
|
:fetched t))))))
|
|
(let ((line (line-number-at-pos)))
|
|
(flan-cnr--render flan-cnr--state)
|
|
(goto-char (point-min))
|
|
(forward-line (1- line)))))
|
|
|
|
(defun flan-cnr-inspect ()
|
|
"Open the inspector on the thing at point.
|
|
|
|
A local and a global reach it by different roots, and that is the fix rather
|
|
than an inconsistency. A global is reached by *name*: the loaded thunk binds
|
|
to the program's own storage through the dynamic linker, so its name is an
|
|
expression that means the same thing wherever it is evaluated. A local is
|
|
not — it is storage in one frame, and its name evaluated anywhere else may
|
|
find a global, another binding of the same name, or nothing. So a local goes
|
|
in by frame and slot index, which is what the listing above it is already
|
|
drawn from."
|
|
(interactive)
|
|
(let ((root (get-text-property (point) 'flan-cnr-inspect)))
|
|
(unless root
|
|
;; Two different misses, and saying the wrong one sends someone looking
|
|
;; for a missing feature when they are one keystroke away. Being *on* a
|
|
;; frame is the common case — the frame line is what the eye lands on —
|
|
;; so name TAB rather than repeating why a local might be absent.
|
|
(user-error
|
|
(if (get-text-property (point) 'flan-cnr-frame)
|
|
"flan: this is the frame's own line; TAB opens it, then i on a local"
|
|
"flan: point is not on a local or a global — TAB opens a frame, i inspects a local in it or a global below")))
|
|
(require 'flan-inspect)
|
|
(pcase root
|
|
(`(:slot ,frame ,slot ,name) (flan-inspect-slot frame slot name))
|
|
(`(:expr ,expr) (flan-inspect expr))
|
|
(_ (user-error "flan: this line carries no root the inspector knows")))))
|
|
|
|
(defun flan-cnr-refresh ()
|
|
"Ask the program again what it is offering."
|
|
(interactive)
|
|
(flan-cnr-show))
|
|
|
|
(defun flan-cnr-next ()
|
|
"Move to the next line that does something."
|
|
(interactive)
|
|
(let ((p (point)))
|
|
(forward-line 1)
|
|
(while (and (not (eobp)) (not (flan-cnr--actionable-p (point))))
|
|
(forward-line 1))
|
|
(when (eobp) (goto-char p))))
|
|
|
|
(defun flan-cnr-previous ()
|
|
"Move to the previous line that does something."
|
|
(interactive)
|
|
(let ((p (point)))
|
|
(forward-line -1)
|
|
(while (and (not (bobp)) (not (flan-cnr--actionable-p (point))))
|
|
(forward-line -1))
|
|
(unless (flan-cnr--actionable-p (point)) (goto-char p))))
|
|
|
|
(defun flan-cnr--actionable-p (pos)
|
|
(or (get-text-property pos 'flan-cnr-restart)
|
|
(get-text-property pos 'flan-cnr-shadowed)
|
|
(get-text-property pos 'flan-cnr-abort)
|
|
(get-text-property pos 'flan-cnr-frame)
|
|
(get-text-property pos 'flan-cnr-inspect)))
|
|
|
|
(defun flan-cnr-tab ()
|
|
"Fold this frame, or move to the next actionable line.
|
|
|
|
TAB does two things because the buffer has two kinds of line and the section
|
|
header already promised the first one: on a frame, it opens or closes that
|
|
frame's locals; anywhere else, it moves. `f' still folds unconditionally, for
|
|
anyone who would rather TAB always moved."
|
|
(interactive)
|
|
(if (get-text-property (point) 'flan-cnr-frame)
|
|
(flan-cnr-toggle-frame)
|
|
(flan-cnr-next)))
|
|
|
|
(defvar flan-cnr-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map (kbd "RET") #'flan-cnr-take)
|
|
(define-key map [mouse-1] #'flan-cnr-take)
|
|
(define-key map (kbd "TAB") #'flan-cnr-tab)
|
|
(define-key map [backtab] #'flan-cnr-previous)
|
|
(define-key map "n" #'flan-cnr-next)
|
|
(define-key map "p" #'flan-cnr-previous)
|
|
(define-key map "f" #'flan-cnr-toggle-frame)
|
|
(define-key map "i" #'flan-cnr-inspect)
|
|
(define-key map "a" #'flan-cnr-abort)
|
|
(define-key map "g" #'flan-cnr-refresh)
|
|
(define-key map "q" #'quit-window)
|
|
;; Numbered, as SBCL's are, and for SBCL's reason: the names are not
|
|
;; unique, so the number is the only unambiguous handle a person has.
|
|
(dotimes (i 10)
|
|
(define-key map (kbd (number-to-string i)) #'flan-cnr-take-number))
|
|
map)
|
|
"Keys in `flan-cnr-mode'.")
|
|
|
|
(define-derived-mode flan-cnr-mode special-mode "flan-break"
|
|
"What a stopped Flan program is offering."
|
|
(setq buffer-read-only t))
|
|
|
|
(defun flan-cnr-state-from-reply (reply &optional fields stack globals)
|
|
"The buffer's state, out of a `break' REPLY.
|
|
FIELDS is what `flan-cnr-condition-fields' returned — rows of
|
|
(NAME TYPE VALUE), with VALUE nil where it could not be read, and the
|
|
one-sentence reason beside them — or the bare rows, which is how the
|
|
fixture-driven tests pass them.
|
|
|
|
GLOBALS is what `flan-cnr-globals' returned, or nil.
|
|
|
|
Everything this cannot fill in is left nil deliberately: the renderer draws a
|
|
section saying why rather than leaving one out, and a section that is absent
|
|
cannot be told from one that is empty.
|
|
|
|
Takes the layout rather than fetching it, so this stays a function from data to
|
|
data and the fixture-driven tests can drive it without a socket."
|
|
(list :condition (plist-get reply :condition)
|
|
:restarts (plist-get reply :restarts)
|
|
;; The two facts about that list nothing here could work out. A
|
|
;; position is on `:unreachable' when the program will refuse it, and
|
|
;; `:abandon' is the position that drops the evaluation this break is
|
|
;; inside — nil when it is not inside one, which is a break the program
|
|
;; took on its own.
|
|
:unreachable (plist-get reply :unreachable)
|
|
:abandon (plist-get reply :abandon)
|
|
;; And why they are refused, which `:abandon' being nil cannot say: a
|
|
;; trap refuses every one of them, an evaluation that is not there
|
|
;; refuses none.
|
|
:trap (plist-get reply :trap)
|
|
;; Where the expression that trapped is written, and that line's text.
|
|
;; `break' carries both when the stop has a site; a user (error ...)
|
|
;; has none, and then the headline simply has no line to point at.
|
|
:site (plist-get reply :site)
|
|
:source (plist-get reply :source)
|
|
;; FIELDS is either the rows themselves — the fixtures' shape — or
|
|
;; `flan-cnr-condition-fields''s plist of rows plus the one-sentence
|
|
;; reason the values half is missing.
|
|
:fields (if (keywordp (car-safe fields))
|
|
(plist-get fields :fields)
|
|
fields)
|
|
:fields-why (and (keywordp (car-safe fields)) (plist-get fields :why))
|
|
:fields-empty (and (keywordp (car-safe fields))
|
|
(plist-get fields :empty))
|
|
;; STACK is passed in rather than fetched, for the same reason FIELDS
|
|
;; is: this stays a function from data to data, so the fixture tests
|
|
;; drive it with no socket. Nil is still a legitimate answer — the
|
|
;; renderer draws the reason rather than leaving the section out.
|
|
:stack stack
|
|
:locals nil
|
|
;; Three keys rather than one nested structure: the renderer draws the
|
|
;; entries, the per-global refusals and the unattributable frames in
|
|
;; three different shapes, and a plist it can `plist-get' each of is
|
|
;; what keeps `flan-cnr--insert-globals' a function of its argument.
|
|
:globals (nth 0 globals)
|
|
:globals-refused (nth 1 globals)
|
|
:globals-skipped (nth 2 globals)))
|
|
|
|
(defun flan-cnr-layout (type)
|
|
"The fields of TYPE, as the renderer wants them, or nil.
|
|
`layout' is answered out of the daemon's own `Tast.structs' — it owns the
|
|
build — so this costs no round trip to the program and works while it is
|
|
stopped, which is the only moment this buffer exists in.
|
|
|
|
TYPE is the string `break' reported as `:condition', and that string is the
|
|
qualified struct name the compiler put into the error: `Emit' takes it from
|
|
`Types.Named', the agent holds it in `condition_name', and the daemon looks it
|
|
up by the same name. So it resolves without anything here knowing what package
|
|
it came from.
|
|
|
|
A refusal is not an error here: `:fields' nil means the section draws the
|
|
reason it is empty, which is the degradation the buffer is already built for,
|
|
and `:why' carries the daemon's own sentence for it — a bare name it will not
|
|
guess between two packages reads better than anything this end could invent.
|
|
|
|
Returns (:fields ROWS :why WHY), the shape `flan-cnr-condition-fields'
|
|
returns, so the two are interchangeable where the buffer takes either."
|
|
(let ((r (and type (not (string-empty-p type))
|
|
(funcall flan-cnr-request-function
|
|
(list :op "layout" :type type)))))
|
|
(if (equal (plist-get r :status) "ok")
|
|
(list :fields
|
|
(mapcar (lambda (f)
|
|
;; The value is nil: the shape of a condition is a
|
|
;; fact about the build, its contents are a fact about
|
|
;; the stopped frame, and this op only ever answers
|
|
;; the first.
|
|
(list (nth 0 f) (nth 1 f) nil))
|
|
(plist-get r :fields))
|
|
:why "the stop's value was not readable")
|
|
(list :fields nil :why (plist-get r :message)))))
|
|
|
|
(defun flan-cnr-condition-fields (type)
|
|
"The stopped condition's fields with their values, or what stands in.
|
|
Asks `condition' first — the daemon builds a thunk that renders the fields at
|
|
the pointer the break loop stashed — and falls back to `layout' when that is
|
|
refused, so the names and the types still show with one sentence saying why
|
|
the values do not. Returns (:fields ROWS :why WHY): ROWS are
|
|
(NAME TYPE VALUE [WHY]) with VALUE nil where it was not read, and WHY is the
|
|
section-wide reason, nil when the values arrived."
|
|
(let ((r (funcall flan-cnr-request-function '(:op "condition"))))
|
|
(if (equal (plist-get r :status) "ok")
|
|
(list :fields
|
|
(append
|
|
(mapcar (lambda (f) (list (nth 0 f) (nth 1 f) (nth 2 f)))
|
|
(plist-get r :fields))
|
|
;; A field the renderer refused — no printer for its type —
|
|
;; still shows, with its own reason in the value column.
|
|
(mapcar (lambda (f) (list (nth 0 f) nil nil (nth 1 f)))
|
|
(plist-get r :refused)))
|
|
:why nil
|
|
;; The build's own count. Zero means this condition declares no
|
|
;; fields, which is a fact about it and not a failure to read
|
|
;; one.
|
|
:empty (eql 0 (plist-get r :declared)))
|
|
;; The shape alone, through the one function that spells the `layout'
|
|
;; request. Its own reason is kept when it is the one that refused —
|
|
;; "not a qualified name" says more than anything about the values —
|
|
;; and the values' reason otherwise.
|
|
(let* ((why (plist-get r :message))
|
|
(fallback (flan-cnr-layout type)))
|
|
(list :fields (plist-get fallback :fields)
|
|
:why (if (plist-get fallback :fields)
|
|
(or why (plist-get fallback :why))
|
|
(or (plist-get fallback :why) why)))))))
|
|
|
|
(defun flan-cnr-backtrace ()
|
|
"The stopped program's frames, innermost first, as the renderer wants them.
|
|
|
|
Unlike `flan-cnr-layout', this *does* reach the program: the frame chain is the
|
|
shadow stack the dev build pushes, and only the stopped thread can read it. It
|
|
is taken from a snapshot made when the break was entered, for the same reason
|
|
the restart list is — a stack that is still moving cannot be numbered.
|
|
|
|
Frames are marked `program' or `eval'. An `eval' frame belongs to an
|
|
expression evaluated *inside* the break loop, sitting on top of the frames that
|
|
were there when it stopped; it is shown rather than hidden, because \"why is
|
|
there a frame I did not write\" is a fair question and silence is the wrong
|
|
answer to it.
|
|
|
|
Locals are left nil here and fetched per frame when one is opened. A stopped
|
|
program has as many sets of locals as it has frames, and rendering all of them
|
|
to draw one is the backtrace problem one level down."
|
|
(let ((r (funcall flan-cnr-request-function '(:op "backtrace"))))
|
|
(when (equal (plist-get r :status) "ok")
|
|
(mapcar (lambda (f)
|
|
(list :fn (nth 0 f) :loc (nth 1 f)
|
|
:kind (nth 2 f) :nslots (nth 3 f)
|
|
:locals nil :fetched nil))
|
|
(plist-get r :frames)))))
|
|
|
|
(defun flan-cnr-locals (frame)
|
|
"What FRAME's named locals hold, as (NAME TYPE VALUE) rows.
|
|
|
|
Returns two values in one list: the rows, and the refusals — a slot the daemon
|
|
declined to show, with the reason. The refusals are shown, not dropped: a
|
|
local that is missing because the compiler invented it and a local that is
|
|
missing because this is broken look identical if only one of them is drawn.
|
|
|
|
Nothing is copied out of the program. The daemon compiles a thunk that renders
|
|
the types it already knows at the addresses the program hands back, which is
|
|
why this works at all while the thread is stopped."
|
|
(let ((r (funcall flan-cnr-request-function (list :op "locals" :frame frame))))
|
|
(if (equal (plist-get r :status) "ok")
|
|
(list (plist-get r :locals) (plist-get r :refused))
|
|
(list nil (list (list "" (or (plist-get r :message) "refused")))))))
|
|
|
|
(defun flan-cnr-globals ()
|
|
"The globals the stopped stack reaches: (ENTRIES REFUSED SKIPPED).
|
|
|
|
ENTRIES are (NAME TYPE VALUE FRAMES) rows, ordered by the innermost frame that
|
|
touches each one, with FRAMES the indices of every frame that does.
|
|
|
|
Unlike the locals, this is fetched once for the whole buffer rather than per
|
|
frame when one is opened, and that follows from what it is: a section scoped to
|
|
the stack has one answer, and asking per frame would be asking the same
|
|
question as many times as there are frames and then unioning the results here.
|
|
|
|
REFUSED is a global the structural printer had no arm for, by name and with the
|
|
reason. SKIPPED is a *frame* the daemon could not attribute — an expression's
|
|
own frame, a lifted handler clause, or a body redefined since it was entered —
|
|
which matters because it means the union is smaller than the real one. Both
|
|
are drawn rather than dropped, for the reason the whole buffer is built on: a
|
|
list that is missing something and a list that is complete look identical if
|
|
nothing says which it is."
|
|
(let ((r (funcall flan-cnr-request-function '(:op "globals"))))
|
|
(when (equal (plist-get r :status) "ok")
|
|
(list (plist-get r :globals)
|
|
(plist-get r :refused)
|
|
(plist-get r :skipped)))))
|
|
|
|
;;;###autoload
|
|
(defun flan-cnr-show ()
|
|
"Show what the stopped program is offering, in a buffer.
|
|
Refuses while the program is running, by name: there is no restart stack to
|
|
walk from a running program."
|
|
(interactive)
|
|
(let ((r (funcall flan-cnr-request-function '(:op "break"))))
|
|
(unless (equal (plist-get r :status) "ok")
|
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))
|
|
(unless (plist-get r :stopped)
|
|
(user-error "flan: the program is running; there is no restart stack to walk"))
|
|
(let ((buf (get-buffer-create flan-cnr-buffer)))
|
|
(with-current-buffer buf
|
|
(unless (derived-mode-p 'flan-cnr-mode) (flan-cnr-mode))
|
|
(flan-cnr--render
|
|
(flan-cnr-state-from-reply r
|
|
(flan-cnr-condition-fields
|
|
(plist-get r :condition))
|
|
(flan-cnr-backtrace)
|
|
(flan-cnr-globals))))
|
|
(pop-to-buffer buf)
|
|
buf)))
|
|
|
|
(provide 'flan-cnr)
|
|
;;; flan-cnr.el ends here
|