1122 lines
56 KiB
EmacsLisp
1122 lines
56 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. Of its filters one was taken: the prelude's frames are
|
|
;; hidden until `P' shows them, because `(pause)' is itself a prelude function
|
|
;; and its frame is the breakpoint, not a step of the program.
|
|
;;
|
|
;; 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-visit-loc "flan" (loc subject))
|
|
(declare-function flan--forget-break-stack "flan" ())
|
|
(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.")
|
|
(defvar-local flan-cnr--show-prelude nil
|
|
"Whether the stack section draws the prelude's own frames.
|
|
Nil by default: a prelude frame is library code the program called, most
|
|
often `pause' itself, and `P' shows them.")
|
|
|
|
(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
|
|
'flan-cnr-loc site 'mouse-face 'highlight))
|
|
(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")
|
|
;; The runtime's own sentence about it, when it wrote one: what the
|
|
;; fields below mean, or — for a trap, which has no fields — the whole of
|
|
;; what is known.
|
|
(let ((sentence (plist-get state :sentence)))
|
|
(when sentence (insert sentence "\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")
|
|
;; A trap is not a struct. Its sentence, above, is what
|
|
;; there is to say about it.
|
|
((and (plist-get state :trap) (plist-get state :sentence))
|
|
" a trap carries no fields; the sentence above is what it refused\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))
|
|
(details (plist-get state :details))
|
|
(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))
|
|
(d (nth i details))
|
|
(report (let ((x (plist-get d :report)))
|
|
(and (stringp x) (not (string-empty-p x)) x)))
|
|
(params (and (> (or (plist-get d :arity) 0) 0)
|
|
(plist-get d :params)))
|
|
(at (plist-get d :at))
|
|
(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))
|
|
;; What it takes, when it takes anything: taking it asks for one
|
|
;; value of each of these types.
|
|
(when params
|
|
(insert (propertize params 'face 'font-lock-type-face) " "))
|
|
(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))))
|
|
;; The clause's own sentence, SBCL's `:report'; after a refusal's
|
|
;; words when there are any, because those say whether it can be
|
|
;; taken at all. The name is the report when the clause wrote
|
|
;; none, as in SBCL, so nothing is added then.
|
|
(when (and report (not (eq kind 'abandon)))
|
|
(when (or owner (memq kind '(unreachable trapped))) (insert " "))
|
|
(insert report))
|
|
(when at
|
|
(insert (propertize (format " (%s)" at) 'face 'shadow)))
|
|
(insert "\n")
|
|
(add-text-properties start (point)
|
|
(list 'flan-cnr-restart name
|
|
'flan-cnr-restart-loc at
|
|
'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--prelude-frame-p (fr)
|
|
"Whether FR is a frame of a prelude function.
|
|
The prelude is compiled into every program and its functions report their
|
|
location as `<prelude>:LINE:COL'. `(pause)' is one: the frame it pushes is the
|
|
breakpoint the program's author wrote, not a step of the program."
|
|
(let ((loc (plist-get fr :loc)))
|
|
(and (stringp loc) (string-prefix-p "<prelude>:" loc))))
|
|
|
|
(defun flan-cnr--insert-hidden (n)
|
|
"The line standing in for N consecutive prelude frames that are hidden."
|
|
(let ((start (point)))
|
|
(insert (propertize
|
|
(format " %d prelude frame%s hidden — P shows %s\n"
|
|
n (if (= n 1) "" "s") (if (= n 1) "it" "them"))
|
|
'face 'shadow))
|
|
(add-text-properties start (point)
|
|
(list 'flan-cnr-hidden t 'mouse-face 'highlight))))
|
|
|
|
(defun flan-cnr--insert-stack (state)
|
|
(flan-cnr--section
|
|
"Stack (innermost first) — RET visits a frame's source, TAB folds its locals:")
|
|
(let ((frames (plist-get state :stack)))
|
|
(if (null frames)
|
|
(insert (flan-cnr--unavailable 'stack))
|
|
(let ((i -1) (hidden 0))
|
|
(dolist (fr frames)
|
|
(setq i (1+ i))
|
|
;; A hidden frame keeps its number. The index is what `locals' and
|
|
;; the inspector are asked by, so the frames either side of a hidden
|
|
;; run are numbered with a gap, and the line in the gap says why.
|
|
;;
|
|
;; The innermost frame is where the program stopped, so it is shown
|
|
;; even when it is the prelude's — unless the stop is `(pause)',
|
|
;; whose own frame is the breakpoint and not where anything failed.
|
|
(if (and (not flan-cnr--show-prelude)
|
|
(flan-cnr--prelude-frame-p fr)
|
|
(or (> i 0)
|
|
(equal (plist-get state :condition) flan-cnr-breakpoint)))
|
|
(setq hidden (1+ hidden))
|
|
(when (> hidden 0)
|
|
(flan-cnr--insert-hidden hidden)
|
|
(setq hidden 0))
|
|
(flan-cnr--insert-frame i fr)))
|
|
(when (> hidden 0) (flan-cnr--insert-hidden hidden)))))
|
|
(insert "\n"))
|
|
|
|
(defun flan-cnr--insert-frame (i fr)
|
|
"Draw frame I, FR, and its locals when it is open."
|
|
(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)
|
|
(append (list 'flan-cnr-frame i 'mouse-face 'highlight)
|
|
(when (plist-get fr :loc)
|
|
(list 'flan-cnr-loc (plist-get fr :loc))))))
|
|
;; 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))))))))
|
|
|
|
(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 RET on a frame visits it TAB fold P prelude frames i inspect a abort 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-hidden) (flan-cnr-toggle-prelude))
|
|
((or (get-text-property (point) 'flan-cnr-frame)
|
|
(get-text-property (point) 'flan-cnr-loc))
|
|
(flan-cnr-visit))
|
|
(t (user-error "flan: nothing to take on this line"))))
|
|
|
|
(defun flan-cnr--loc-subject (pos)
|
|
"What the location at POS is the location of, for a refusal."
|
|
(let ((i (get-text-property pos 'flan-cnr-frame)))
|
|
(if i
|
|
(format "frame %d, %s," i
|
|
(or (plist-get (nth i (plist-get flan-cnr--state :stack)) :fn)
|
|
"?"))
|
|
"the stop")))
|
|
|
|
(defun flan-cnr-visit ()
|
|
"Visit the source of the frame, or of the stop, on this line.
|
|
A frame's location is where its function is written; the stop's is the
|
|
expression that stopped."
|
|
(interactive)
|
|
(let ((loc (get-text-property (point) 'flan-cnr-loc))
|
|
(rloc (get-text-property (point) 'flan-cnr-restart-loc)))
|
|
(cond
|
|
(loc (flan-visit-loc loc (flan-cnr--loc-subject (point))))
|
|
;; A restart's clause, which `v' reaches and RET does not: RET takes it.
|
|
(rloc (flan-visit-loc rloc (format "restart %s"
|
|
(get-text-property (point)
|
|
'flan-cnr-restart))))
|
|
((get-text-property (point) 'flan-cnr-restart)
|
|
(user-error "flan: this restart was established from C and has no source"))
|
|
(t
|
|
(user-error
|
|
(if (get-text-property (point) 'flan-cnr-frame)
|
|
"flan: this frame has no location; the program did not report one"
|
|
"flan: point is not on a frame, a restart or the stop"))))))
|
|
|
|
(defun flan-cnr-toggle-prelude ()
|
|
"Show or hide the prelude's frames in the stack section."
|
|
(interactive)
|
|
(setq flan-cnr--show-prelude (not flan-cnr--show-prelude))
|
|
(let ((line (line-number-at-pos)))
|
|
(flan-cnr--render flan-cnr--state)
|
|
(goto-char (point-min))
|
|
(forward-line (1- line)))
|
|
(message "flan: prelude frames %s"
|
|
(if flan-cnr--show-prelude "shown" "hidden")))
|
|
|
|
(defun flan-cnr--visitable-line-p (pos)
|
|
"Whether the line at POS carries a location `next-error' can visit.
|
|
A location in angle brackets, `<prelude>', names no file, so the walk steps
|
|
over it rather than stopping on a refusal."
|
|
(let ((loc (get-text-property pos 'flan-cnr-loc)))
|
|
(and loc (not (string-prefix-p "<" loc)))))
|
|
|
|
(defun flan-cnr-next-error (&optional n reset)
|
|
"The break buffer's `next-error-function': walk the stop and its frames.
|
|
Moves N lines that carry a visitable location, from the top when RESET, and
|
|
visits the source of the one it lands on."
|
|
(setq n (or n 1))
|
|
(let ((dir (if (< n 0) -1 1))
|
|
(left (abs n))
|
|
(found nil))
|
|
(save-excursion
|
|
(if reset (goto-char (point-min)) (beginning-of-line))
|
|
;; From the top, the first step lands on the first location rather than
|
|
;; the second; and a count of zero means the line point is on.
|
|
(when (and (or reset (zerop left)) (flan-cnr--visitable-line-p (point)))
|
|
(setq left (max 0 (1- left)) found (point)))
|
|
(while (and (> left 0) (zerop (forward-line dir)) (not (eobp)))
|
|
(when (flan-cnr--visitable-line-p (point))
|
|
(setq left (1- left) found (point)))))
|
|
(when (or (> left 0) (null found))
|
|
(user-error "flan: no more frames with a source location"))
|
|
(goto-char found)
|
|
(let ((win (get-buffer-window (current-buffer))))
|
|
(when win (set-window-point win found)))
|
|
(flan-visit-loc (get-text-property found 'flan-cnr-loc)
|
|
(flan-cnr--loc-subject found))))
|
|
|
|
(defun flan-cnr--forget ()
|
|
"The stack this buffer drew is gone; stop `next-error' walking it."
|
|
(when (eq next-error-last-buffer (current-buffer))
|
|
(setq next-error-last-buffer nil)))
|
|
|
|
(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"))
|
|
(flan-cnr--forget)
|
|
(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"))
|
|
(flan-cnr--forget)
|
|
(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-hidden)
|
|
(get-text-property pos 'flan-cnr-loc)
|
|
(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 "v" #'flan-cnr-visit)
|
|
(define-key map "P" #'flan-cnr-toggle-prelude)
|
|
(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'.")
|
|
|
|
;; Evil's normal state binds 0, the other digits and RET above any major
|
|
;; mode's map, so under Evil a digit moved point or started a count and took
|
|
;; nothing. The keys this file binds are given to Evil's normal and motion
|
|
;; states in this mode. Only those keys: `flan-cnr-mode-map' inherits
|
|
;; `special-mode-map', and making it an overriding map would carry h, SPC, <
|
|
;; and - over from there as well. Every key not listed stays Evil's.
|
|
(with-eval-after-load 'evil
|
|
(when (fboundp 'evil-define-key*)
|
|
;; Collected first, and without the parent's bindings, because
|
|
;; `evil-define-key*' writes into the map being walked.
|
|
(let ((own nil))
|
|
(map-keymap-internal (lambda (key def)
|
|
(when (commandp def) (push (cons key def) own)))
|
|
flan-cnr-mode-map)
|
|
(dolist (b own)
|
|
(evil-define-key* '(normal motion) flan-cnr-mode-map
|
|
(vector (car b)) (cdr b))))))
|
|
|
|
(define-derived-mode flan-cnr-mode special-mode "flan-break"
|
|
"What a stopped Flan program is offering."
|
|
(setq buffer-read-only t)
|
|
;; `next-error' walks the stop and then the frames, innermost first, the way
|
|
;; it walks a compiler's messages.
|
|
(setq-local next-error-function #'flan-cnr-next-error))
|
|
|
|
(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)
|
|
;; Beside each name and in the same order: a plist of its `:report'
|
|
;; sentence, where the clause is written (`:at'), and the types it
|
|
;; takes (`:arity', `:params').
|
|
:details (plist-get reply :details)
|
|
;; 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)
|
|
;; The runtime's sentence about the stop, when it wrote one.
|
|
:sentence (plist-get reply :sentence)
|
|
;; 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)))
|
|
;; So `M-g M-n' from the source buffer walks this stack rather than
|
|
;; the last compilation's errors. Taken back when a restart or an
|
|
;; abort is accepted, here or from `flan.el', and when the poll sees
|
|
;; the program running again: see `flan--forget-break-stack'.
|
|
(setq next-error-last-buffer buf))
|
|
(pop-to-buffer buf)
|
|
buf)))
|
|
|
|
(provide 'flan-cnr)
|
|
;;; flan-cnr.el ends here
|