Joseph Ferano
2179627593
The client already knew the moment: flan-dev--absorb reads :stopped off every reply and the poll covers the case where no reply is coming. This is a hook at that point, not new plumbing. Deferred through a zero-delay timer, which is the part that is not optional. absorb notices the stop in the middle of reading a reply on the socket, with flan-dev--busy bound, and showing the buffer asks the daemon three more questions — break, layout, backtrace. Issuing those from inside the read they were triggered by would interleave two conversations on one connection. The deferred call re-checks the state rather than trusting the edge that scheduled it, because by then the edge has been consumed and the program may have been resumed. Three decisions, settled and written down beside the code. It displays and does not select. A program stops on its own clock, not the editor's, and the likeliest moment is a frame of its own game loop while someone is typing somewhere else. Taking the window would send the next keystrokes where they were not aimed. `focus' is there for anyone who disagrees, and nil goes back to the mode line alone. (pause) is not a special case, though it was worth asking: it is deliberate at the moment it is *written*, and the frame it fires on still arrives whenever the program gets there, which is no more expected than an error. What it does get is an honest headline. (pause) is `error' under a `restart-case', so nothing in the compiler knows a breakpoint from a failure and this buffer is the first place that can — calling it unhandled is a small lie at the top of the one buffer that exists to say what happened. A stop mid-edit disturbs nothing, which falls out of displaying rather than selecting. Two guards go past that: nothing happens under an active minibuffer, because a prompt is modal and rearranging windows under one is hostile; and nothing happens inside a keyboard macro, because a macro that behaves differently depending on whether the program stopped cannot be trusted. In both cases the mode line still says stopped and C-c C-b still works.
705 lines
35 KiB
EmacsLisp
705 lines
35 KiB
EmacsLisp
;;; test-flan-cider.el --- The inspector and break buffers, from fixtures -*- lexical-binding: t; -*-
|
|
|
|
;; Run as: emacs -Q --batch -L emacs -l emacs/test-flan-cider.el
|
|
;;
|
|
;; Nothing here needs a daemon or a running program, and that is deliberate
|
|
;; rather than a shortcut. Both buffers are functions from *a reply's data* to
|
|
;; *text with properties on it*, and the interesting failures are all on that
|
|
;; side: a struct the reader mis-parses, a shadowed restart drawn as though it
|
|
;; could be chosen, a section quietly omitted instead of refused. Driving it
|
|
;; from fixtures tests exactly that, and it tests the cases a live program
|
|
;; cannot easily be made to produce — a value past the renderer's depth bound,
|
|
;; two restarts with one name, a frame with locals in it at all.
|
|
;;
|
|
;; The fixtures are not invented. Every rendered string below is the shape
|
|
;; `Session.render' writes, case by case, and the comment on each says which.
|
|
|
|
;;; Code:
|
|
|
|
(require 'flan-inspect)
|
|
(require 'flan-cnr)
|
|
;; For `flan-dev--auto-break', which is a decision about globals and windows
|
|
;; and needs neither a daemon nor a socket to be asked.
|
|
(require 'flan-dev)
|
|
|
|
(defvar test-flan--failures 0)
|
|
(defvar test-flan--ran 0)
|
|
|
|
(defun test-flan--check (name ok)
|
|
(setq test-flan--ran (1+ test-flan--ran))
|
|
(if ok (message " ok %s" name)
|
|
(setq test-flan--failures (1+ test-flan--failures))
|
|
(message " FAIL %s" name)))
|
|
|
|
(defun test-flan--text (thunk)
|
|
"Run THUNK in a scratch buffer and return what it drew."
|
|
(with-temp-buffer
|
|
(funcall thunk)
|
|
(buffer-substring-no-properties (point-min) (point-max))))
|
|
|
|
(defun test-flan--caught (thunk)
|
|
"The message of the error THUNK signals, or nil if it does not."
|
|
(condition-case e (progn (funcall thunk) nil)
|
|
(error (error-message-string e))))
|
|
|
|
|
|
;;; The reader
|
|
|
|
(message "\nreading what the renderer wrote")
|
|
|
|
;; (V {.x 1.5 .y 0}) — Types.Named, lib/session.ml.
|
|
(let ((n (flan-inspect-parse "(V {.x 1.5 .y 0})")))
|
|
(test-flan--check "a struct is a struct" (eq (plist-get n :kind) 'struct))
|
|
(test-flan--check "with its type name" (equal (plist-get n :type) "V"))
|
|
(test-flan--check "and its fields in order"
|
|
(equal (mapcar #'car (plist-get n :children)) '("x" "y")))
|
|
(test-flan--check "carrying their values"
|
|
(equal (plist-get (cdr (assoc "x" (plist-get n :children))) :text)
|
|
"1.5")))
|
|
|
|
;; The whole of NEXT.md's worked example, nested two deep with a string that
|
|
;; has escaped quotes in it and a slice at the end.
|
|
(let* ((src "(Blob {.id 7 .name \"sandy \\\"quoted\\\"\" .pos (V {.x 1.5 .y 0}) .tags [ 0 42 0]})")
|
|
(n (flan-inspect-parse src))
|
|
(kids (plist-get n :children)))
|
|
(test-flan--check "every field of a nested struct"
|
|
(equal (mapcar #'car kids) '("id" "name" "pos" "tags")))
|
|
(test-flan--check "an escaped quote does not end the string early"
|
|
(equal (plist-get (cdr (assoc "name" kids)) :text)
|
|
"\"sandy \"quoted\"\""))
|
|
(test-flan--check "a struct inside a struct"
|
|
(equal (plist-get (cdr (assoc "pos" kids)) :type) "V"))
|
|
(test-flan--check "a slice inside a struct, with its elements"
|
|
(equal (mapcar #'car (plist-get (cdr (assoc "tags" kids)) :children))
|
|
'(0 1 2))))
|
|
|
|
;; [ 0 42 0] — Types.Slice and Types.Array both write this.
|
|
(let ((n (flan-inspect-parse "[ 0 42 0]")))
|
|
(test-flan--check "a sequence is a sequence" (eq (plist-get n :kind) 'seq))
|
|
(test-flan--check "indexed from zero"
|
|
(equal (mapcar #'car (plist-get n :children)) '(0 1 2))))
|
|
|
|
;; [ [ 0 0] [ 1 ...] ...] — span truncation at both levels, which is what
|
|
;; sand's [100 [100 u32]] actually produces.
|
|
(let* ((n (flan-inspect-parse "[ [ 0 0] [ 1 ...] ...]"))
|
|
(kids (plist-get n :children)))
|
|
(test-flan--check "a trailing ... is truncation, not an element"
|
|
(and (= (length kids) 2) (plist-get n :truncated)))
|
|
(test-flan--check "and it is noticed on the inner sequence too"
|
|
(plist-get (cdr (nth 1 kids)) :truncated)))
|
|
|
|
;; The renderer's refusals, each of which becomes a leaf here.
|
|
(test-flan--check "a pointer is a pointer"
|
|
(eq (plist-get (flan-inspect-parse "<ptr>") :kind) 'ptr))
|
|
(test-flan--check "a type the walk had no structure for"
|
|
(eq (plist-get (flan-inspect-parse "<Widget>") :kind) 'opaque))
|
|
(test-flan--check "the depth bound"
|
|
(eq (plist-get (flan-inspect-parse "...") :kind) 'trunc))
|
|
(test-flan--check "an option"
|
|
(eq (plist-get (flan-inspect-parse "(some 3)") :kind) 'option))
|
|
(test-flan--check "an enum member is an atom, not a field"
|
|
(eq (plist-get (flan-inspect-parse ":blue") :kind) 'atom))
|
|
(test-flan--check "and so is a u64 that fills the range"
|
|
(equal (plist-get (flan-inspect-parse "18446744073709551615") :text)
|
|
"18446744073709551615"))
|
|
|
|
;; A struct with a `...' where a field would be: span truncation *inside* a
|
|
;; struct, which is a different position in the grammar from a sequence's.
|
|
(let ((n (flan-inspect-parse "(Wide {.a 1 .b 2 ...})")))
|
|
(test-flan--check "a struct's span bound is truncation, not a field"
|
|
(and (equal (mapcar #'car (plist-get n :children)) '("a" "b"))
|
|
(plist-get n :truncated))))
|
|
|
|
|
|
;;; Where a field is, said in Flan
|
|
|
|
(message "\nthe path is an expression")
|
|
|
|
(test-flan--check "a field is a field accessor"
|
|
(equal (flan-inspect-step-expr "b" '(:field "pos")) "(.pos b)"))
|
|
(test-flan--check "an element is `at'"
|
|
(equal (flan-inspect-step-expr "(.tags b)" '(:index 2))
|
|
"(at (.tags b) 2)"))
|
|
(test-flan--check "and they compose, which is the whole trick"
|
|
(equal (flan-inspect-step-expr
|
|
(flan-inspect-step-expr "b" '(:field "pos")) '(:field "x"))
|
|
"(.x (.pos b))"))
|
|
|
|
|
|
;;; Refusals, by name, with the reason
|
|
|
|
(message "\nwhat cannot be entered says so")
|
|
|
|
(dolist (case '(("<ptr>" "pointer") ("..." "depth bound") ("7" "atom")
|
|
("(some 3)" "accessor form") ("<Widget>" "no structure")))
|
|
(let ((why (flan-inspect-refusal (flan-inspect-parse (car case)))))
|
|
(test-flan--check (format "%s refuses, naming %s" (car case) (cadr case))
|
|
(and why (string-match-p (regexp-quote (cadr case)) why)))))
|
|
|
|
(test-flan--check "a struct with fields does not refuse"
|
|
(null (flan-inspect-refusal (flan-inspect-parse "(V {.x 1 .y 2})"))))
|
|
|
|
(test-flan--check "and a pointer says the address is not there either"
|
|
(string-match-p "does not write the address"
|
|
(flan-inspect-refusal
|
|
(flan-inspect-parse "<ptr>"))))
|
|
|
|
|
|
;;; What a number reads as in the other two bases
|
|
|
|
;; Arithmetic on text the renderer already wrote: nothing is asked of the
|
|
;; program, which is why these need no daemon and no fixture beyond the string.
|
|
|
|
(message "\na number in the other bases")
|
|
|
|
(dolist (case '(("255" "0xFF" "0b1111_1111")
|
|
("0" "0x0" "0b0")
|
|
("7" "0x7" "0b0111")
|
|
;; sand.flan's world-edge colour, which is the case this is for:
|
|
;; written 0x303030FF in the source and decimal everywhere else.
|
|
("808464639" "0x303030FF" "0b0011_0000_0011_0000_0011_0000_1111_1111")))
|
|
(let ((detail (flan-inspect--detail (flan-inspect-parse (nth 0 case)))))
|
|
(test-flan--check (format "%s is %s" (nth 0 case) (nth 1 case))
|
|
(and detail (string-match-p (regexp-quote (nth 1 case)) detail)))
|
|
(test-flan--check (format "%s is %s" (nth 0 case) (nth 2 case))
|
|
(and detail (string-match-p (regexp-quote (nth 2 case)) detail)))))
|
|
|
|
;; A negative is the 64-bit two's complement it is in memory, and says so: the
|
|
;; rendered value carries no width, and every Flan integer comes back through
|
|
;; i64, so 64 is the one that can be stated honestly.
|
|
(let ((detail (flan-inspect--detail (flan-inspect-parse "-1"))))
|
|
(test-flan--check "a negative is two's complement, at a stated width"
|
|
(and detail
|
|
(string-match-p "0xFFFFFFFFFFFFFFFF" detail)
|
|
(string-match-p "64-bit" detail))))
|
|
|
|
;; The whole u64 range, which is past a fixnum and relies on bignums.
|
|
(test-flan--check "a u64 at the top of its range"
|
|
(string-match-p
|
|
"0xFFFFFFFFFFFFFFFF"
|
|
(or (flan-inspect--detail
|
|
(flan-inspect-parse "18446744073709551615")) "")))
|
|
|
|
;; Not everything that looks numeric is one. A float's bits are an IEEE layout
|
|
;; and the rendered text does not carry the width to reinterpret them, so it is
|
|
;; left alone rather than answered wrongly.
|
|
(dolist (text '("1.5" "-0.25" "true" ":green" "none" "..." "<ptr>" "\"7\""))
|
|
(test-flan--check (format "%s has no other base" text)
|
|
(null (flan-inspect--detail (flan-inspect-parse text)))))
|
|
|
|
;; And it reaches the buffer, in both places it is drawn: the header of a value
|
|
;; opened on its own, and the field list where a leaf can only ever be seen.
|
|
(let ((flan-inspect-request-function
|
|
(lambda (_) '(:status "ok" :value "255")))
|
|
(flan-inspect-buffer " *test-inspect*"))
|
|
(let ((text (with-current-buffer (save-window-excursion (flan-inspect "flags"))
|
|
(buffer-string))))
|
|
(test-flan--check "a number opened on its own shows its bases"
|
|
(string-match-p "0xFF 0b1111_1111" text))))
|
|
|
|
(let ((flan-inspect-request-function
|
|
(lambda (_) '(:status "ok" :value "(Mask {.bits 255 .name \"all\"})")))
|
|
(flan-inspect-buffer " *test-inspect*"))
|
|
(let ((text (with-current-buffer (save-window-excursion (flan-inspect "m"))
|
|
(buffer-string))))
|
|
(test-flan--check "and a numeric field shows them in the field list"
|
|
(string-match-p "\\.bits +255 +0xFF 0b1111_1111" text))
|
|
(test-flan--check "while a string field is left alone"
|
|
(string-match-p "\\.name +\"all\"\n" text))))
|
|
|
|
|
|
;;; The inspector buffer
|
|
|
|
(message "\nthe inspector buffer")
|
|
|
|
(defun test-flan--inspect (expr rendered)
|
|
"Draw EXPR's RENDERED value in a temp buffer and return it, live."
|
|
(let ((flan-inspect-request-function
|
|
(lambda (_) (list :status "ok" :value rendered)))
|
|
(flan-inspect-buffer " *test-inspect*"))
|
|
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
|
|
(save-window-excursion (flan-inspect--show expr nil))))
|
|
|
|
(let* ((buf (test-flan--inspect
|
|
"b" "(Blob {.id 7 .name \"sandy\" .pos (V {.x 1.5 .y 0})})"))
|
|
(text (with-current-buffer buf (buffer-string))))
|
|
(test-flan--check "the expression is at the top" (string-match-p "\\`b\n" text))
|
|
(test-flan--check "and the type under it" (string-match-p "a Blob" text))
|
|
(test-flan--check "the fields are listed" (string-match-p "\\.id.*7" text))
|
|
(test-flan--check "a nested struct is summarised, not expanded"
|
|
(string-match-p "\\.pos +(V … 2 fields)" text))
|
|
(test-flan--check "and the keys are shown" (string-match-p "RET inspect" text))
|
|
;; Every field line carries the step that reaches it.
|
|
(with-current-buffer buf
|
|
(goto-char (point-min))
|
|
(flan-inspect-next)
|
|
(test-flan--check "TAB lands on the first field"
|
|
(equal (get-text-property (point) 'flan-inspect-step)
|
|
'(:field "id")))
|
|
(flan-inspect-next)
|
|
(flan-inspect-next)
|
|
(test-flan--check "and walks to the third"
|
|
(equal (get-text-property (point) 'flan-inspect-step)
|
|
'(:field "pos")))
|
|
;; Backwards is the same list walked the other way. It is tested because
|
|
;; an asymmetry here is the kind of thing nobody reports and everybody
|
|
;; notices — and because point lands mid-line after a search, where a
|
|
;; property-change walk and a field walk disagree.
|
|
(flan-inspect-previous)
|
|
(test-flan--check "p comes back to the second"
|
|
(equal (get-text-property (point) 'flan-inspect-step)
|
|
'(:field "name")))
|
|
;; From the middle of a line, `p' goes to the start of the field point is
|
|
;; *in*, which is CIDER's behaviour and the reason both commands go
|
|
;; through one list of field starts: walking property changes from
|
|
;; mid-line finds the end of the current field instead, and forward and
|
|
;; backward then disagree about where a field begins.
|
|
(end-of-line)
|
|
(flan-inspect-previous)
|
|
(test-flan--check "from mid-line, p reaches this field's start"
|
|
(equal (get-text-property (point) 'flan-inspect-step)
|
|
'(:field "name")))
|
|
(flan-inspect-previous)
|
|
(test-flan--check "and then the one before it"
|
|
(equal (get-text-property (point) 'flan-inspect-step)
|
|
'(:field "id")))
|
|
(flan-inspect-previous)
|
|
(test-flan--check "p wraps to the last, as n wraps to the first"
|
|
(equal (get-text-property (point) 'flan-inspect-step)
|
|
'(:field "pos")))
|
|
(flan-inspect-next)
|
|
(test-flan--check "and n wraps round from it"
|
|
(equal (get-text-property (point) 'flan-inspect-step)
|
|
'(:field "id")))))
|
|
|
|
;; Going in sends a *different expression*, which is the entire adaptation.
|
|
(let ((asked nil))
|
|
(let ((flan-inspect-request-function
|
|
(lambda (form)
|
|
(push (plist-get form :code) asked)
|
|
(list :status "ok"
|
|
:value (if (equal (plist-get form :code) "(.pos b)")
|
|
"(V {.x 1.5 .y 0})"
|
|
"(Blob {.id 7 .pos (V {.x 1.5 .y 0})})"))))
|
|
(flan-inspect-buffer " *test-inspect*"))
|
|
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
|
|
(save-window-excursion
|
|
(flan-inspect--show "b" nil)
|
|
(with-current-buffer " *test-inspect*"
|
|
(goto-char (point-min))
|
|
(flan-inspect-next) (flan-inspect-next) ; :pos
|
|
(flan-inspect-into)
|
|
(test-flan--check "going in asks for the accessor expression"
|
|
(equal (car asked) "(.pos b)"))
|
|
(test-flan--check "and the buffer is now showing that"
|
|
(string-match-p "\\`(\\.pos b)\n" (buffer-string)))
|
|
(test-flan--check "with the stack behind it"
|
|
(string-match-p "via b > here" (buffer-string)))
|
|
(flan-inspect-pop)
|
|
(test-flan--check "coming back asks for the one we came from"
|
|
(equal (car asked) "b"))
|
|
(test-flan--check "and there is no stack left"
|
|
(not (string-match-p "via" (buffer-string))))
|
|
(test-flan--check "popping at the root refuses"
|
|
(string-match-p
|
|
"nothing behind it"
|
|
(or (test-flan--caught #'flan-inspect-pop) "")))))))
|
|
|
|
;; RET on something that cannot be entered refuses there, rather than sending
|
|
;; an expression the program would reject.
|
|
(let* ((buf (test-flan--inspect "p" "(Node {.next <ptr> .n 1})")))
|
|
(with-current-buffer buf
|
|
(goto-char (point-min))
|
|
(flan-inspect-next)
|
|
(test-flan--check "RET on a pointer field refuses, naming it"
|
|
(string-match-p "pointer"
|
|
(or (test-flan--caught #'flan-inspect-into) "")))))
|
|
|
|
;; An atom root has nothing to go into, and the buffer says so rather than
|
|
;; drawing an empty field list.
|
|
(let ((text (with-current-buffer (test-flan--inspect "(.x p)" "1.5") (buffer-string))))
|
|
(test-flan--check "an atom root explains itself"
|
|
(string-match-p "Nothing to go into:.*atom" text)))
|
|
|
|
;; The span bound is drawn, because a field list that silently stops is a lie
|
|
;; about the value.
|
|
(let ((text (with-current-buffer
|
|
(test-flan--inspect "w" "(Wide {.a 1 .b 2 ...})") (buffer-string))))
|
|
(test-flan--check "span truncation is drawn, not dropped"
|
|
(string-match-p "span bound of 8" text)))
|
|
|
|
|
|
|
|
|
|
;;; 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.
|
|
;; The shape of a condition and the values in it are two different
|
|
;; refusals, and with nothing at all the outer one is what shows.
|
|
(test-flan--check "the condition's fields are refused, not omitted"
|
|
(string-match-p "Condition fields:\n not available.*Tast.structs" text))
|
|
;; The stack is no longer refused for want of a mechanism — the shadow stack
|
|
;; landed and the daemon answers `backtrace'. What this fixture has is no
|
|
;; stack *passed in*, which is the running-program case, so the reason it
|
|
;; names is that one.
|
|
(test-flan--check "the stack says the program is running, not that it is unbuilt"
|
|
(string-match-p "Stack.*\n not available.*running"
|
|
(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. The fixture is the shape `backtrace' and `locals'
|
|
;; answer with, and both frames carry `:fetched t' because their locals are
|
|
;; already here: without it `flan-cnr-toggle-frame' goes and asks the daemon
|
|
;; for them, and there is no daemon behind these tests on purpose.
|
|
(let* ((state (list :condition "Missing"
|
|
:restarts '("retry")
|
|
:stack (list (list :fn "sim/settle" :loc "sand.flan:42:3"
|
|
:fetched t
|
|
:locals '(("i" "i32" "7")
|
|
("b" "Blob" "(Blob {.id 7})")))
|
|
(list :fn "sim/step" :loc "sand.flan:60:1"
|
|
:fetched t :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)
|
|
;; DWARF stopped being the reason when the shadow stack landed: a frame
|
|
;; with nothing nameable is one whose slots the compiler invented, or whose
|
|
;; bindings had not run.
|
|
(test-flan--check "a frame with no locals refuses, with a reason"
|
|
(string-match-p "not available.*no named locals"
|
|
(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" :fetched t
|
|
: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.
|
|
;; The layout without the values: what a `layout' op alone would buy. The
|
|
;; names and the types come out of Tast.structs, which the daemon holds
|
|
;; whether or not a program is running; only the values need the pointer the
|
|
;; break loop was handed. Drawing the two apart is strictly more than saying
|
|
;; nothing, and it is what tells you whether the field you were about to
|
|
;; blame is even a field of this condition.
|
|
(let ((text (with-current-buffer
|
|
(test-flan--cnr (list :condition "Missing" :restarts '("retry")
|
|
:fields '(("path" "string" nil)
|
|
("tried" "i32" "3"))))
|
|
(buffer-string))))
|
|
(test-flan--check "a field is named and typed even with no value"
|
|
(string-match-p ":path *string *value not available" text))
|
|
(test-flan--check "and the missing value names the verb it needs"
|
|
(string-match-p "value not available.*agent verb: `condition'" text))
|
|
(test-flan--check "a value that is there is simply shown"
|
|
(string-match-p ":tried *i32 *3" text)))
|
|
|
|
;; Backwards through the buffer, for the same reason as in the inspector.
|
|
(with-current-buffer (test-flan--cnr
|
|
(list :condition "Missing" :restarts '("retry" "skip")))
|
|
(goto-char (point-min))
|
|
(search-forward "[abort]")
|
|
(beginning-of-line)
|
|
(flan-cnr-previous)
|
|
(test-flan--check "p from abort lands on the last restart"
|
|
(equal (get-text-property (point) 'flan-cnr-index) 1))
|
|
(flan-cnr-next)
|
|
(test-flan--check "and n goes back to abort"
|
|
(get-text-property (point) 'flan-cnr-abort)))
|
|
|
|
|
|
;; The `layout' op, from this side: the condition's own name goes out as
|
|
;; `:type' and comes back as fields with no values. Two requests are made for
|
|
;; one `C-c C-b' — `break', `layout', then `backtrace' — so the stub records
|
|
;; all three. The assertions below look the `layout' request up by op rather
|
|
;; than by position: this list grew once already when `backtrace' landed, and a
|
|
;; positional assertion breaks every time the buffer learns to ask something
|
|
;; new, which is not what it is testing.
|
|
(let ((asked nil))
|
|
(let ((flan-cnr-request-function
|
|
(lambda (form)
|
|
(push form asked)
|
|
(pcase (plist-get form :op)
|
|
("break" '(:status "ok" :stopped t :condition "sim/Missing"
|
|
:restarts ("retry")))
|
|
("layout" '(:status "ok" :type "sim/Missing"
|
|
:fields (("path" "string") ("tried" "i32"))))))))
|
|
(let ((text (with-current-buffer (save-window-excursion (flan-cnr-show))
|
|
(buffer-string))))
|
|
(test-flan--check "the condition's name is what `layout' is asked for"
|
|
(equal (plist-get (car (last asked)) :op) "break"))
|
|
;; By op rather than by position: `flan-cnr-show' asks three things now —
|
|
;; `break', `layout', `backtrace' — and which of them is last is not what
|
|
;; this is testing.
|
|
(test-flan--check "and it is sent back verbatim, qualified as it came"
|
|
(equal (plist-get
|
|
(seq-find (lambda (f)
|
|
(equal (plist-get f :op) "layout"))
|
|
asked)
|
|
:type)
|
|
"sim/Missing"))
|
|
(test-flan--check "the fields are drawn, named and typed"
|
|
(string-match-p ":path *string" text))
|
|
;; Shape and contents are two different questions, and only the first is
|
|
;; answerable without the pointer the break loop discards.
|
|
(test-flan--check "and every value still says why it is missing"
|
|
(string-match-p ":tried *i32 *value not available" text)))))
|
|
|
|
;; A layout the daemon refuses — a bare name it will not guess between two
|
|
;; packages, or a type it cannot place — leaves the section drawing its reason
|
|
;; rather than turning `C-c C-b' into an error. The restarts are the decision
|
|
;; in front of you and they are still there.
|
|
(let ((flan-cnr-request-function
|
|
(lambda (form)
|
|
(pcase (plist-get form :op)
|
|
("break" '(:status "ok" :stopped t :condition "Missing"
|
|
:restarts ("retry")))
|
|
("layout" '(:status "error" :message "Missing is not a qualified name"
|
|
:candidates ("a/Missing" "b/Missing")))))))
|
|
(let ((text (with-current-buffer (save-window-excursion (flan-cnr-show))
|
|
(buffer-string))))
|
|
(test-flan--check "a refused layout is a section that says so"
|
|
(string-match-p "not available.*needs a \\*qualified\\* name" text))
|
|
(test-flan--check "and the restarts are drawn anyway"
|
|
(string-match-p "\\[retry\\]" text))))
|
|
|
|
(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) ""))))
|
|
|
|
|
|
;;; Opening the break buffer by itself
|
|
|
|
;; `flan-dev--auto-break' is a decision — given the state the client is in,
|
|
;; does the break buffer appear — so it is asked here with the state bound
|
|
;; rather than by stopping a real program. Every guard in it exists because
|
|
;; the answer is no in some state a person is actually in.
|
|
|
|
(message "\nthe break buffer opening itself")
|
|
|
|
(defun test-flan--auto-break (&rest bindings)
|
|
"Non-nil if `flan-dev--auto-break' would show the buffer.
|
|
BINDINGS is a plist of extra state; the defaults are a live connection and a
|
|
stopped program, which is the case where it should fire."
|
|
(let ((shown nil))
|
|
(cl-letf (((symbol-function 'flan-cnr-show) (lambda () (setq shown t) nil))
|
|
;; A process object that is not live, and `process-live-p' of a
|
|
;; non-process is nil — so the default has to be overridden by
|
|
;; the caller, which is what `:live' does.
|
|
((symbol-function 'process-live-p)
|
|
(lambda (_) (if (plist-member bindings :live)
|
|
(plist-get bindings :live) t))))
|
|
(let ((flan-dev--stopped
|
|
(if (plist-member bindings :stopped)
|
|
(plist-get bindings :stopped) "Missing"))
|
|
(flan-dev-break-on-stop
|
|
(if (plist-member bindings :setting)
|
|
(plist-get bindings :setting) 'display))
|
|
(flan-dev--busy (plist-get bindings :busy))
|
|
(executing-kbd-macro (plist-get bindings :macro))
|
|
(flan-dev--connection 'stub))
|
|
(flan-dev--auto-break)))
|
|
shown))
|
|
|
|
(test-flan--check "a stopped program opens it"
|
|
(test-flan--auto-break))
|
|
(test-flan--check "a running one does not"
|
|
(not (test-flan--auto-break :stopped nil)))
|
|
(test-flan--check "nor does a connection that has gone"
|
|
(not (test-flan--auto-break :live nil)))
|
|
;; The reason it is deferred at all: `flan-dev--absorb' notices the stop in the
|
|
;; middle of reading a reply, and three more requests down the same socket
|
|
;; would interleave two conversations.
|
|
(test-flan--check "nor while a request is still in flight"
|
|
(not (test-flan--auto-break :busy t)))
|
|
;; A prompt is modal and someone is in the middle of it.
|
|
(test-flan--check "nor under an active minibuffer"
|
|
(let ((probe (lambda (&rest _) t)))
|
|
(advice-add 'active-minibuffer-window :override probe)
|
|
(unwind-protect (not (test-flan--auto-break))
|
|
(advice-remove 'active-minibuffer-window probe))))
|
|
;; A macro must do the same thing every time it is run, and whether the program
|
|
;; happened to stop during it is not something a macro can depend on.
|
|
(test-flan--check "nor inside a keyboard macro"
|
|
(not (test-flan--auto-break :macro t)))
|
|
(test-flan--check "and not at all when it is turned off"
|
|
(not (test-flan--auto-break :setting nil)))
|
|
|
|
;; `(pause)' is a stop and not a failure, and it is the one thing about it that
|
|
;; the buffer gets to say differently. Everything underneath is identical.
|
|
(let ((text (test-flan--text
|
|
(lambda () (flan-cnr--insert-condition
|
|
(list :condition flan-cnr-breakpoint))))))
|
|
(test-flan--check "a breakpoint is called a breakpoint"
|
|
(string-match-p "a breakpoint; stopped where (pause)" text))
|
|
(test-flan--check "and is not called unhandled"
|
|
(not (string-match-p "unhandled" text))))
|
|
|
|
(let ((text (test-flan--text
|
|
(lambda () (flan-cnr--insert-condition '(:condition "Missing"))))))
|
|
(test-flan--check "while an error still is"
|
|
(string-match-p "unhandled" text)))
|
|
|
|
|
|
;; `flan-mode' itself — indentation, which is a function from text to text and
|
|
;; so belongs with the other fixture-driven checks rather than with anything
|
|
;; that needs a daemon. Loaded rather than run separately because
|
|
;; `emacs/*.el' is already a dependency of test/dune's stanza, so a file here
|
|
;; needs no build change to be run.
|
|
(load (expand-file-name "test-flan-mode.el"
|
|
(file-name-directory load-file-name))
|
|
nil t)
|
|
|
|
(message "\n%d checks, %d failures" test-flan--ran test-flan--failures)
|
|
(kill-emacs (if (> test-flan--failures 0) 1 0))
|
|
|
|
;;; test-flan-cider.el ends here
|