Joseph Ferano
a9a411709c
C-c C-b is a completing-read over restart names, which is the whole UI for the one moment the dev loop exists to make survivable. It shows the names and nothing else, and it will let you pick one that cannot be taken. That last part is a bug, not a gap. §4 says restart lookup takes the first frame offering a name, and flan_find_restart does exactly that; so a second frame offering "retry" is real, is on the list, and is unreachable — picking it sends the string "retry" and the inner frame runs, silently. SBCL has shown this since forever by numbering the restarts and omitting the bracket on a name already used. Taken as is, and the shadowed row now refuses by name and says what would fix it: an index verb, which does not exist. SBCL also decides the order. invoke-debugger prints the condition, then show-restarts, and stops; the backtrace is a command you type. The restarts are the decision and the stack is the explanation for it, and a debugger that opens with forty frames has buried one under the other. What CIDER's stacktrace buffer gives is the behaviour — frames that fold in place, everything on the keyboard. Not its cause chain: a JVM exception wraps another one and a Flan condition wraps nothing. The fields, the stack and the locals are drawn as sections that say why they are empty and what each would take. A section left out cannot be told from one that happened to have nothing in it, and only one of those is a fact about the program.
398 lines
18 KiB
EmacsLisp
398 lines
18 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
|
|
'((fields
|
|
. "the break loop is handed the condition as an opaque pointer and its class name; nothing at run time can render a value whose type it does not know, and the pointer never leaves the program [needs an agent verb: `condition', plus a daemon-built render thunk]")
|
|
(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
|
|
. "a Flan build carries no frame metadata, so there is nothing to walk the stopped stack with [blocked: needs DWARF]")
|
|
(locals
|
|
. "reading a stopped frame's locals needs both the frame layout and a renderer aimed at an address rather than at an expression [blocked: needs DWARF, 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:")
|
|
(let ((fields (plist-get state :fields)))
|
|
(if (null fields)
|
|
(insert (flan-cnr--unavailable 'fields))
|
|
(let ((w (apply #'max 4 (mapcar (lambda (f) (length (car f))) fields))))
|
|
(dolist (f fields)
|
|
(let ((start (point)))
|
|
(insert (format " :%s%s %s\n" (car f)
|
|
(make-string (- w (length (car f))) ?\s)
|
|
(cadr f)))
|
|
(add-text-properties start (point)
|
|
(list 'flan-cnr-inspect (caddr f)
|
|
'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)
|
|
"The buffer's state, out of a `break' REPLY.
|
|
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."
|
|
(list :condition (plist-get reply :condition)
|
|
:restarts (plist-get reply :restarts)
|
|
:fields nil ; see `flan-cnr-unavailable'
|
|
:stack nil
|
|
:locals nil))
|
|
|
|
;;;###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)))
|
|
(pop-to-buffer buf)
|
|
buf)))
|
|
|
|
(provide 'flan-cnr)
|
|
;;; flan-cnr.el ends here
|