A stopped program should show its choices, not spell them
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.
This commit is contained in:
parent
94b78a1a83
commit
a9a411709c
397
emacs/flan-cnr.el
Normal file
397
emacs/flan-cnr.el
Normal file
@ -0,0 +1,397 @@
|
||||
;;; 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
|
||||
@ -17,6 +17,7 @@
|
||||
;;; Code:
|
||||
|
||||
(require 'flan-inspect)
|
||||
(require 'flan-cnr)
|
||||
|
||||
(defvar test-flan--failures 0)
|
||||
(defvar test-flan--ran 0)
|
||||
@ -228,6 +229,192 @@
|
||||
|
||||
|
||||
|
||||
|
||||
;;; Restarts: which of them can be taken
|
||||
|
||||
(message "\nrestarts, and §4's shadowing")
|
||||
|
||||
(let ((rows (flan-cnr-annotate-restarts '("retry" "use-placeholder" "retry" "skip"))))
|
||||
(test-flan--check "numbered from zero, innermost first"
|
||||
(equal (mapcar (lambda (r) (nth 0 r)) rows) '(0 1 2 3)))
|
||||
(test-flan--check "the first of a name owns it"
|
||||
(null (nth 2 (nth 0 rows))))
|
||||
(test-flan--check "a repeat is shadowed by it"
|
||||
(equal (nth 2 (nth 2 rows)) 0))
|
||||
(test-flan--check "and a different name is not"
|
||||
(null (nth 2 (nth 3 rows)))))
|
||||
|
||||
(test-flan--check "no restarts is a list of no rows"
|
||||
(null (flan-cnr-annotate-restarts nil)))
|
||||
|
||||
|
||||
;;; The break buffer
|
||||
|
||||
(message "\nthe break buffer")
|
||||
|
||||
(defun test-flan--cnr (state)
|
||||
"Draw STATE and return the buffer."
|
||||
(let ((buf (get-buffer-create " *test-cnr*")))
|
||||
(with-current-buffer buf
|
||||
(let ((inhibit-read-only t)) (erase-buffer))
|
||||
(flan-cnr-mode)
|
||||
(setq flan-cnr--open nil)
|
||||
(flan-cnr--render state))
|
||||
buf))
|
||||
|
||||
;; What the daemon can answer today, and nothing more: a class name and a list
|
||||
;; of names.
|
||||
(let* ((buf (test-flan--cnr
|
||||
(list :condition "Missing"
|
||||
:restarts '("retry" "use-placeholder" "retry"))))
|
||||
(text (with-current-buffer buf (buffer-string))))
|
||||
;; SBCL's order, which is the claim this buffer is making.
|
||||
(test-flan--check "the condition is first"
|
||||
(string-match-p "\\`Missing" text))
|
||||
(test-flan--check "the restarts are before the stack"
|
||||
(< (string-match "Restarts" text) (string-match "Stack" text)))
|
||||
(test-flan--check "restarts are numbered"
|
||||
(string-match-p " 0: \\[retry\\]" text))
|
||||
(test-flan--check "a shadowed one has no bracket, as SBCL's has none"
|
||||
(string-match-p " 2: retry " text))
|
||||
(test-flan--check "and says why, and what it would take"
|
||||
(string-match-p "shadowed by 0.*restart-at" text))
|
||||
(test-flan--check "abort is the last entry on the same list"
|
||||
(string-match-p " 3: \\[abort\\]" text))
|
||||
;; The rule: nothing implemented is refused by name, with the reason. These
|
||||
;; three sections exist and are empty, and each says what would fill it.
|
||||
(test-flan--check "the condition's fields are refused, not omitted"
|
||||
(string-match-p "Condition fields:\n not available.*opaque pointer" text))
|
||||
(test-flan--check "the stack is refused, naming DWARF"
|
||||
(string-match-p "Stack.*\n not available.*DWARF"
|
||||
(substring text (string-match "--- Stack" text))))
|
||||
(test-flan--check "and the keys are shown" (string-match-p "TAB fold a frame" text)))
|
||||
|
||||
;; A stopped program with nothing on offer between the error and the top. It
|
||||
;; is a real state — spec-conditions §2's `error' with no `restart-case' above
|
||||
;; it — and it must not look like a bug in the buffer.
|
||||
(let ((text (with-current-buffer
|
||||
(test-flan--cnr (list :condition "Missing" :restarts nil))
|
||||
(buffer-string))))
|
||||
(test-flan--check "no restarts is said, not drawn blank"
|
||||
(string-match-p "none are active" text))
|
||||
(test-flan--check "and abort is still offered"
|
||||
(string-match-p " 0: \\[abort\\]" text)))
|
||||
|
||||
;; Taking one sends `restart' with the name.
|
||||
(let ((sent nil))
|
||||
(let ((flan-cnr-request-function
|
||||
(lambda (form) (setq sent form) (list :status "ok" :note "accepted"))))
|
||||
(with-current-buffer (test-flan--cnr
|
||||
(list :condition "Missing" :restarts '("retry" "skip")))
|
||||
(goto-char (point-min))
|
||||
(search-forward " 1: ")
|
||||
(save-window-excursion (flan-cnr-take))
|
||||
(test-flan--check "RET on a restart sends its name"
|
||||
(equal sent '(:op "restart" :name "skip"))))))
|
||||
|
||||
;; And a shadowed one is refused here rather than sent, which is the bug in
|
||||
;; today's `completing-read': it would send "retry" and the *inner* frame would
|
||||
;; take it, silently.
|
||||
(let ((sent nil))
|
||||
(let ((flan-cnr-request-function (lambda (form) (setq sent form) '(:status "ok"))))
|
||||
(with-current-buffer (test-flan--cnr
|
||||
(list :condition "Missing" :restarts '("retry" "a" "retry")))
|
||||
(goto-char (point-min))
|
||||
(search-forward " 2: ")
|
||||
(let ((err (test-flan--caught #'flan-cnr-take)))
|
||||
(test-flan--check "a shadowed restart refuses"
|
||||
(and err (string-match-p "shadowed by 0" err)))
|
||||
(test-flan--check "and nothing was sent" (null sent))))))
|
||||
|
||||
;; A digit takes one, as it does in SBCL.
|
||||
(let ((sent nil))
|
||||
(let ((flan-cnr-request-function
|
||||
(lambda (form) (setq sent form) (list :status "ok" :note "accepted"))))
|
||||
(with-current-buffer (test-flan--cnr
|
||||
(list :condition "Missing" :restarts '("retry" "skip")))
|
||||
(goto-char (point-max))
|
||||
(let ((last-command-event ?0))
|
||||
(save-window-excursion (call-interactively #'flan-cnr-take-number)))
|
||||
(test-flan--check "0 takes the innermost"
|
||||
(equal sent '(:op "restart" :name "retry")))
|
||||
(let ((last-command-event ?2))
|
||||
(save-window-excursion (call-interactively #'flan-cnr-take-number)))
|
||||
(test-flan--check "and the number past the last is abort"
|
||||
(equal sent '(:op "abort"))))))
|
||||
|
||||
;; The stack and its locals. Nothing produces this data today; the fixture is
|
||||
;; the shape a `backtrace' verb would have to answer with, and building the
|
||||
;; buffer against it is how it is ready when one exists.
|
||||
(let* ((state (list :condition "Missing"
|
||||
:restarts '("retry")
|
||||
:stack (list (list :fn "sim/settle" :loc "sand.flan:42:3"
|
||||
:locals '(("i" "i32" "7")
|
||||
("b" "Blob" "(Blob {:id 7})")))
|
||||
(list :fn "sim/step" :loc "sand.flan:60:1"
|
||||
:locals nil))))
|
||||
(buf (test-flan--cnr state))
|
||||
(text (with-current-buffer buf (buffer-string))))
|
||||
(test-flan--check "frames are numbered, innermost first"
|
||||
(string-match-p " 0: > sim/settle" text))
|
||||
(test-flan--check "with where they are" (string-match-p "sand.flan:42:3" text))
|
||||
(test-flan--check "locals are collapsed to begin with"
|
||||
(not (string-match-p "i32 i = 7" text)))
|
||||
(with-current-buffer buf
|
||||
(goto-char (point-min))
|
||||
(search-forward " 0: > sim/settle")
|
||||
(flan-cnr-toggle-frame)
|
||||
(test-flan--check "TAB on a frame opens its locals"
|
||||
(string-match-p "i32 i = 7" (buffer-string)))
|
||||
(test-flan--check "and the marker turns"
|
||||
(string-match-p " 0: v sim/settle" (buffer-string)))
|
||||
;; A frame whose locals nobody could read says so, in the same place the
|
||||
;; locals would have been.
|
||||
(goto-char (point-min))
|
||||
(search-forward " 1: > sim/step")
|
||||
(flan-cnr-toggle-frame)
|
||||
(test-flan--check "a frame with no locals refuses, naming DWARF"
|
||||
(string-match-p "not available.*DWARF" (buffer-string)))
|
||||
(goto-char (point-min))
|
||||
(search-forward " 0: v sim/settle")
|
||||
(flan-cnr-toggle-frame)
|
||||
(test-flan--check "and TAB again closes it"
|
||||
(not (string-match-p "i32 i = 7" (buffer-string))))))
|
||||
|
||||
;; The two buffers meet: `i' on a local opens the inspector on its name, which
|
||||
;; is an expression the program can be handed.
|
||||
(let ((asked nil))
|
||||
(let ((flan-inspect-request-function
|
||||
(lambda (form) (push (plist-get form :code) asked)
|
||||
(list :status "ok" :value "(Blob {:id 7})")))
|
||||
(flan-inspect-buffer " *test-inspect*"))
|
||||
(with-current-buffer (test-flan--cnr
|
||||
(list :condition "Missing" :restarts '("retry")
|
||||
:stack (list (list :fn "f" :locals '(("b" "Blob" "…"))))))
|
||||
(goto-char (point-min))
|
||||
(search-forward " 0: > f")
|
||||
(flan-cnr-toggle-frame)
|
||||
(goto-char (point-min))
|
||||
(search-forward "Blob b")
|
||||
(save-window-excursion (flan-cnr-inspect))
|
||||
(test-flan--check "`i' on a local inspects it by name"
|
||||
(equal (car asked) "b")))))
|
||||
|
||||
;; `flan-cnr-show' refuses a running program by name rather than opening an
|
||||
;; empty buffer.
|
||||
(let ((flan-cnr-request-function
|
||||
(lambda (_) '(:status "ok" :restarts nil :stopped nil))))
|
||||
(test-flan--check "a running program is refused, by name"
|
||||
(string-match-p "no restart stack"
|
||||
(or (test-flan--caught #'flan-cnr-show) ""))))
|
||||
|
||||
(let ((flan-cnr-request-function
|
||||
(lambda (_) '(:status "error" :message "the program exited"))))
|
||||
(test-flan--check "and the daemon's own refusal is passed through"
|
||||
(string-match-p "the program exited"
|
||||
(or (test-flan--caught #'flan-cnr-show) ""))))
|
||||
|
||||
|
||||
(message "\n%d checks, %d failures" test-flan--ran test-flan--failures)
|
||||
(kill-emacs (if (> test-flan--failures 0) 1 0))
|
||||
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user