Joseph Ferano
4d29e52dbe
`i' on a local sent the local's *name* to be evaluated, and an expression is evaluated where the evaluator stands. That is the right frame only when the frame is the innermost one; on any other it may resolve to a global, to another binding of the same name, or to nothing, with the locals listing right above it showing the frame's own storage and nothing saying the two disagree. The daemon verb for the fix landed already. What was missing was the state layer under it: `flan-inspect--expr' held a bare expression, so there was nowhere to put a frame. It is `flan-inspect--root' and `flan-inspect--path' now — `(:expr E)' or `(:slot FRAME SLOT NAME)', plus the steps walked from it — and a stack entry is `(ROOT PATH . POINT)'. RET appends a step, `l' restores a pair it pushed. Every step is still a fresh request, so the view is never stale. `l' cannot cross between the two roots, and that is structural rather than a rule someone has to keep: RET only ever extends the path under the root the buffer already has, and `flan-inspect' and `flan-inspect-slot' both start with an empty stack, so a mixed stack cannot be built at all. It stays true if a third rooting mode is added. The break buffer hands over the frame and the slot *index*, which is the fourth element `locals' now puts on each line. A name does not identify a slot: two slots of one frame can share one, and a refused slot is not in the listing, so its position is not an identifier either. A global still goes in by name, because a global's name really is an expression that means the same thing wherever it is evaluated — the loaded thunk binds to the program's own storage through the dynamic linker. Two smaller things the wire needed. A field step carries the type it was read out of, because a union's payload is at an offset that depends on the case and only the renderer knows which case the value is in — so `Union.case.field', which is the head the renderer wrote with the field appended. And an empty path is sent by omission: Emacs prints an empty list as `nil', which is a symbol on the wire, so the daemon now reads that as no path rather than refusing it as a step.
682 lines
34 KiB
EmacsLisp
682 lines
34 KiB
EmacsLisp
;;; flan-cnr.el --- What a stopped program is offering -*- lexical-binding: t; -*-
|
|
|
|
;; `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 is invoked by name; the name resolves to the innermost frame
|
|
;; offering it; so a second frame offering `retry' is real, is on the list, and
|
|
;; **cannot be chosen by name**. spec-conditions.md §4 says exactly this about
|
|
;; Flan ("takes the first frame offering the name"), and `flan_find_restart'
|
|
;; does exactly this in the runtime. Today's `completing-read' hides it: the
|
|
;; list has `retry' in it twice, picking either sends the string "retry", and
|
|
;; the inner one runs. Here the shadowed entry is drawn and refused, by name,
|
|
;; with the reason.
|
|
;;
|
|
;; **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-dev--request "flan-dev" (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-dev--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-dev.el' is named in one place.")
|
|
|
|
;;; What is not available, and why
|
|
|
|
;; Said in one table rather than at each use, because these are claims about
|
|
;; the protocol and they should be revisable in one place when a verb lands.
|
|
;; Each carries its status in the same three words the design uses.
|
|
|
|
(defconst flan-cnr-unavailable
|
|
'((layout
|
|
. "the daemon could not resolve this condition's name to a struct [the `layout' op answers out of `Tast.structs' and needs a *qualified* name. A package qualifies what it declares, so two packages' `Missing' are two names and neither is `Missing'; the daemon refuses a bare one and lists what it could have meant rather than picking. A name it cannot place at all is a program built from source this daemon did not compile]")
|
|
(value
|
|
. "the break loop is handed the condition as an opaque pointer, and `break_loop' currently discards it; nothing at run time can render a value whose type it does not know [needs an agent verb: `condition', to stash and hand back the pointer, and a daemon-built render thunk aimed at it]")
|
|
(site
|
|
. "a restart frame carries its name and the hash matching uses, and no location [needs a location in the restart frame, which the compiler must emit]")
|
|
(params
|
|
. "restart arguments are checked at run time against a frame that does not record its arity [needs a field in the restart frame]")
|
|
(stack
|
|
. "the program is running. A backtrace is the game thread's frame chain and it is changing while it runs, so the daemon refuses to take one [not a missing feature: ask again once it has stopped]")
|
|
(locals
|
|
. "this frame has no named locals the daemon can read. A slot the compiler invented is refused by name rather than shown as `s4', and a slot whose binding had not run when the error happened has no address yet [both are refusals with reasons, not gaps — the frame's own line says how many slots it has]")
|
|
(globals
|
|
. "no frame on this stack references a global [not a gap: the section is the *union of what the frames reach*, not a listing of everything the program has, so an empty one means the state this stack is working on 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--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)))
|
|
(insert (propertize name 'face (if paused 'warning 'error)))
|
|
(insert (propertize
|
|
(if paused
|
|
" — a breakpoint; stopped where (pause) was called, nothing unwound\n"
|
|
" — unhandled; stopped on the frame that erred, nothing unwound\n")
|
|
'face 'shadow)))
|
|
(insert "\n")
|
|
(flan-cnr--section "Condition fields:")
|
|
;; Two refusals, not one, and keeping them apart is the point. The *shape* of
|
|
;; a condition — its field names and their types — is in `Tast.structs',
|
|
;; which the daemon holds because it owns the build; no running program is
|
|
;; involved in answering it. Only the *values* need the pointer the break
|
|
;; loop was handed. So a field can be named and typed while its value is
|
|
;; refused, which is strictly more than saying nothing, and it is what tells
|
|
;; you whether the :path you were about to blame is even a field of this
|
|
;; condition.
|
|
(let ((fields (plist-get state :fields)))
|
|
(if (null fields)
|
|
(insert (flan-cnr--unavailable 'layout))
|
|
(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
|
|
(propertize (concat "value not available — "
|
|
(flan-cnr--why 'value))
|
|
'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.
|
|
(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))
|
|
(if owner
|
|
(insert (propertize
|
|
(format "shadowed by %d — `restart' resolves a name to the innermost frame offering it, so this one cannot be taken by name [needs an agent verb: `restart-at INDEX']" owner)
|
|
'face 'font-lock-comment-face))
|
|
(insert (propertize (flan-cnr--why 'site) 'face 'shadow)))
|
|
(insert "\n")
|
|
(add-text-properties start (point)
|
|
(list 'flan-cnr-restart (if owner nil 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 "let the program die where it stopped; this ends `flan dev' too\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--refuse-shadowed ()
|
|
(user-error
|
|
"flan: restart %d is shadowed by %d; `restart' takes a name, and this name reaches the inner frame. Taking this one needs an index verb the daemon does not have"
|
|
(get-text-property (point) 'flan-cnr-index)
|
|
(get-text-property (point) 'flan-cnr-shadowed)))
|
|
|
|
(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-shadowed) (flan-cnr--refuse-shadowed))
|
|
((get-text-property (point) 'flan-cnr-restart)
|
|
(flan-cnr--invoke (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 (name)
|
|
(let ((r (funcall flan-cnr-request-function (list :op "restart" :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-dev'
|
|
;; 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 the condition's layout, if it was asked for and answered — a list of
|
|
(NAME TYPE VALUE), where VALUE is nil because no running program was consulted
|
|
to get it.
|
|
|
|
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)
|
|
:fields fields
|
|
;; 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, and that is the honest half: the shape
|
|
;; of a condition is a fact about the build, its contents
|
|
;; are a fact about the stopped frame, and only the first is
|
|
;; knowable today.
|
|
(list (nth 0 f) (nth 1 f) nil))
|
|
(plist-get r :fields))))))
|
|
|
|
(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-layout (plist-get r :condition))
|
|
(flan-cnr-backtrace)
|
|
(flan-cnr-globals))))
|
|
(pop-to-buffer buf)
|
|
buf)))
|
|
|
|
(provide 'flan-cnr)
|
|
;;; flan-cnr.el ends here
|