Joseph Ferano
404b8559c5
C-c C-b asks layout with the condition's own name and draws the fields under it. The values stay refused, by name, because the shape of a condition is a fact about the build and its contents are a fact about the stopped frame — and only one of those is knowable today. A layout the daemon refuses is nil rather than an error: the buffer already draws a section saying why one is empty, and failing the whole command would take away the restarts over an annotation.
451 lines
22 KiB
EmacsLisp
451 lines
22 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))
|
|
|
|
(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
|
|
. "nothing here is attached to the stopped program. DWARF is not the gap and has not been for a while: `flan build --debug' emits it, `flan dev --debug' now builds the host and every redefinition module with it, and lldb walks a stack that crosses from a reloaded .so back into the host naming both sides' .flan files. But this buffer reaches the program over the daemon's socket, and a socket cannot read another process's frames — the break loop stopped itself, it is not being debugged. So this wants either an unwinder in the agent, beside `flan_rt.c', or lldb attached to the same pid and this buffer reading it [needs one of those two, not DWARF]")
|
|
(locals
|
|
. "same reason as the stack above it, plus a renderer aimed at an address rather than at an expression. The names and types are in the DWARF now — a let-bound local is its own name there, not `s0' — so whatever walks the frames can read them; nothing is walking the frames [needs the same attachment, and the same thunk the condition's fields need]"))
|
|
"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)))
|
|
|
|
(defun flan-cnr--insert-condition (state)
|
|
(let ((name (or (plist-get state :condition) "a condition")))
|
|
(insert (propertize name 'face 'error))
|
|
(insert (propertize " — 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)))
|
|
(if (null locals)
|
|
(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)))
|
|
(add-text-properties start (point)
|
|
(list 'flan-cnr-inspect (nth 0 l)
|
|
'mouse-face 'highlight)))))))))))
|
|
(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)
|
|
(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)))
|
|
(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."
|
|
(interactive)
|
|
(let ((expr (get-text-property (point) 'flan-cnr-inspect)))
|
|
(unless expr
|
|
(user-error "flan: %s" (flan-cnr--why 'locals)))
|
|
(require 'flan-inspect)
|
|
(flan-inspect expr)))
|
|
|
|
(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)))
|
|
|
|
(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-next)
|
|
(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)
|
|
"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.
|
|
|
|
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
|
|
;; Still nil deliberately: nothing here is attached to the stopped
|
|
;; program's frames, and the renderer says so by name.
|
|
:stack nil
|
|
:locals nil))
|
|
|
|
(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))))))
|
|
|
|
;;;###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)))))
|
|
(pop-to-buffer buf)
|
|
buf)))
|
|
|
|
(provide 'flan-cnr)
|
|
;;; flan-cnr.el ends here
|