Joseph Ferano
abe7e8cd46
A break nested inside a trap's break — a fix candidate evaluated at a bounds stop raising its own error — copied the outer trap's site into its snapshot, which is a caret pointing at an unrelated line under the inner condition's name. snap_push now consumes the global: each snapshot owns its copy, a nested entry that set no fresh site gets none, and the outer break keeps its own. Pinned end to end. The fields section says why the values are missing once, above the rows, instead of repeating the sentence per field; a row keeps its own reason only when it has one (no printer for its type). strip_rebind and shown_names get direct coverage, including the clean strip a real frame almost never reaches.
790 lines
38 KiB
EmacsLisp
790 lines
38 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)
|
|
"Turn NAMES — innermost first — into what the buffer draws.
|
|
Each entry is (INDEX NAME SHADOWED-BY), where SHADOWED-BY is the index of the
|
|
earlier entry that owns the name, or nil.
|
|
|
|
This 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."
|
|
(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)))
|
|
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
|
|
(mapconcat (lambda (f) (format "%s %s" (nth 0 f) (nth 2 f)))
|
|
(seq-take 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))))
|
|
(insert "\n" (propertize prefix 'face 'shadow) source "\n")
|
|
(insert (make-string (+ (length prefix) (max 0 (1- (cdr lc)))) ?\s)
|
|
(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)
|
|
(insert (propertize (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)))
|
|
(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))
|
|
(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.
|
|
(insert (format " %2d: %s%s%s " i
|
|
(if owner " " "[")
|
|
(propertize name 'face
|
|
(if owner 'shadow 'font-lock-keyword-face))
|
|
(if owner " " "]")))
|
|
(insert (make-string (- w (length name)) ?\s))
|
|
(when 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-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))))
|
|
|
|
;;; Commands
|
|
|
|
(defun flan-cnr-take ()
|
|
"Take the restart on this line."
|
|
(interactive)
|
|
(cond
|
|
((get-text-property (point) 'flan-cnr-abort) (flan-cnr-abort))
|
|
((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)
|
|
;; 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))
|
|
;; 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: nil means the layout section draws the reason
|
|
it is empty, which is the degradation the buffer is already built for."
|
|
(when (and type (not (string-empty-p type)))
|
|
(let ((r (funcall flan-cnr-request-function (list :op "layout" :type type))))
|
|
(when (equal (plist-get r :status) "ok")
|
|
(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))))))
|
|
|
|
(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)
|
|
(let* ((why (plist-get r :message))
|
|
(r2 (when (and type (not (string-empty-p type)))
|
|
(funcall flan-cnr-request-function
|
|
(list :op "layout" :type type))))
|
|
(ok2 (equal (plist-get r2 :status) "ok"))
|
|
(layout (when ok2
|
|
(mapcar (lambda (f) (list (nth 0 f) (nth 1 f) nil))
|
|
(plist-get r2 :fields)))))
|
|
(list :fields layout
|
|
:why (or why (unless ok2 (plist-get r2 :message))
|
|
(and layout "the stop's value was not readable")))))))
|
|
|
|
(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
|