Joseph Ferano
c586eed138
flan-watch-ghost-mode paints each watched value inline, after the line holding the call that wrote it. An addition to the watch buffer and not a replacement: both can be on at once, and turning either off leaves the other running. The earlier note said ghost text was gated on a (watch ...) form in check.ml, because nothing in the table carries a source location. That is true of the table and the conclusion did not follow. The call site is in the buffer, and the name in the table is the string literal in it, so the anchor is searched for rather than reported. Nothing new is asked of the daemon. The head of the call is a defcustom regexp, because watch-i64 is a name the program's author chose in their own declare-c and only the C symbol behind it is fixed. Both pictures are painted from one reply in flan-watch--absorb, so they cannot disagree and there is no second watch request in flight. That meant the watch buffer could no longer be the subscription: arming and the timer now hang off flan-watch--consumers, and only the last consumer out disarms the table. Overlays are replaced wholesale on every repaint rather than followed through edits, which is the whole answer to invalidating one whose line moved. Only buffers shown in a window are scanned. Settled and written down: two sites of one name both show it and say so, because the table has one slot and the last writer wins; a watch in a loop shows the last value written, as the buffer does, because every better answer is the query UI this design exists to avoid; a stopped program's values say "last frame" and change face, since inline they sit in code that looks live; a site with no row is annotated only when the table reports overflow. syntax-ppss moves point and clobbers the match data, so calling it inside a re-search-forward loop and then reading match-string restarts the scan and the loop never ends. Everything is read out before the check now. emacs/test-flan-watch.el covers it, loaded from test-flan-cider.el the way test-flan-mode.el is, so no build change is needed. 203 checks, 0 failures.
1022 lines
51 KiB
EmacsLisp
1022 lines
51 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.
|
|
The expression root, which is what most of the block below is about: the
|
|
rooting the buffer has always had, and the one that still works on a running
|
|
program."
|
|
(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 (list :expr 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 '(:expr "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)))
|
|
|
|
|
|
;;; The slot root
|
|
|
|
(message "\nthe slot root: a frame and a slot index")
|
|
|
|
;; The other rooting mode, and the reason it exists: an expression is
|
|
;; evaluated where the evaluator stands, so a local's *name* names the right
|
|
;; storage only on the innermost frame. This root names the frame.
|
|
|
|
(defvar test-flan--asked nil
|
|
"Every request the last slot-root fixture sent, newest first.")
|
|
|
|
(defun test-flan--slot (frame slot name replies body)
|
|
"Open the slot root on FRAME/SLOT/NAME and run BODY in its buffer.
|
|
REPLIES answers each request. BODY runs *inside* the binding of
|
|
`flan-inspect-request-function', which is not optional here: RET and `l' are
|
|
further requests, so a helper that returned the buffer and let the binding
|
|
unwind would send the next one to a daemon that is not there."
|
|
(setq test-flan--asked nil)
|
|
(let ((flan-inspect-request-function
|
|
(lambda (form) (push form test-flan--asked) (funcall replies form)))
|
|
(flan-inspect-buffer " *test-inspect*"))
|
|
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
|
|
(save-window-excursion
|
|
(with-current-buffer (flan-inspect-slot frame slot name)
|
|
(funcall body)))))
|
|
|
|
;; The header names the frame, which is the whole of what the expression root
|
|
;; could not say, and the type comes from the reply rather than being read
|
|
;; back out of the rendering — a rendering of `7' does not carry `i64'.
|
|
(test-flan--slot
|
|
1 3 "b"
|
|
(lambda (_) (list :status "ok" :type "Blob"
|
|
:value "(Blob {.id 7 .pos (V {.x 1.5 .y 0})})"))
|
|
(lambda ()
|
|
(let ((text (buffer-string)))
|
|
(test-flan--check "the slot root names the frame in the header"
|
|
(string-match-p "\\`b \\[frame 1\\]\n" text))
|
|
(test-flan--check "and the daemon's type is what is shown"
|
|
(string-match-p "\nBlob\n" text)))
|
|
(test-flan--check "it asks the inspect op, not eval-expr"
|
|
(equal (plist-get (car test-flan--asked) :op) "inspect"))
|
|
(test-flan--check "with the frame and the slot index it was given"
|
|
(and (= 1 (plist-get (car test-flan--asked) :frame))
|
|
(= 3 (plist-get (car test-flan--asked) :slot))))
|
|
;; An empty path is sent by *omission*: Emacs prints an empty list as
|
|
;; `nil', which is a symbol on the wire and would be refused as a step.
|
|
(test-flan--check "and no :path at all for the slot itself"
|
|
(null (plist-get (car test-flan--asked) :path)))))
|
|
|
|
;; Going in extends the path. The root does not change, and that is what
|
|
;; makes `l' unable to cross: every entry on the stack was pushed with the
|
|
;; root it belongs to, so `l' can only ever restore a pair it built.
|
|
(test-flan--slot
|
|
1 3 "b"
|
|
(lambda (form)
|
|
(if (equal (plist-get form :path) '("pos"))
|
|
(list :status "ok" :type "V" :value "(V {.x 1.5 .y 0})")
|
|
(list :status "ok" :type "Blob"
|
|
:value "(Blob {.id 7 .pos (V {.x 1.5 .y 0})})")))
|
|
(lambda ()
|
|
(goto-char (point-min))
|
|
(flan-inspect-next) (flan-inspect-next) ; .pos
|
|
(flan-inspect-into)
|
|
(test-flan--check "RET sends a path step, not an expression"
|
|
(equal (plist-get (car test-flan--asked) :path) '("pos")))
|
|
(test-flan--check "the header walks with it"
|
|
(string-match-p "\\`b \\[frame 1\\]\\.pos\n" (buffer-string)))
|
|
(test-flan--check "with the frame's own root behind it in the trail"
|
|
(string-match-p "via b \\[frame 1\\] > here" (buffer-string)))
|
|
(flan-inspect-pop)
|
|
(test-flan--check "l shortens the path back to the root"
|
|
(null (plist-get (car test-flan--asked) :path)))
|
|
(test-flan--check "and the root never changed under it"
|
|
(seq-every-p (lambda (f) (equal (plist-get f :op) "inspect"))
|
|
test-flan--asked))
|
|
(test-flan--check "so nothing was ever evaluated as an expression"
|
|
(not (seq-some (lambda (f) (plist-get f :code))
|
|
test-flan--asked)))
|
|
(test-flan--check "and popping at the root refuses, as for an expression"
|
|
(string-match-p
|
|
"nothing behind it"
|
|
(or (test-flan--caught #'flan-inspect-pop) "")))))
|
|
|
|
;; An option's payload: the one thing the slot root reaches and the expression
|
|
;; root cannot, because Flan has no accessor form that names it. So the
|
|
;; refusal is the *root's* and not the value's, and it has to be asked with
|
|
;; the root in hand.
|
|
(test-flan--check "an expression root refuses an option's payload"
|
|
(string-match-p
|
|
"no accessor form"
|
|
(or (flan-inspect-refusal (flan-inspect-parse "(some 3)")
|
|
'(:expr "o"))
|
|
"")))
|
|
(test-flan--check "a slot root does not"
|
|
(null (flan-inspect-refusal (flan-inspect-parse "(some 3)")
|
|
'(:slot 0 1 "o"))))
|
|
|
|
(test-flan--slot
|
|
0 2 "o"
|
|
(lambda (form)
|
|
(if (plist-get form :path)
|
|
(list :status "ok" :type "V" :value "(V {.x 1 .y 2})")
|
|
(list :status "ok" :type "(Option V)" :value "(some (V {.x 1 .y 2}))")))
|
|
(lambda ()
|
|
(goto-char (point-min))
|
|
(flan-inspect-next)
|
|
(flan-inspect-into)
|
|
;; The payload has no name, so the step is the symbol `some' and not a
|
|
;; field called "some".
|
|
(test-flan--check "RET into an option sends the symbol some"
|
|
(equal (plist-get (car test-flan--asked) :path) '(some)))
|
|
(test-flan--check "and the trail says so"
|
|
(string-match-p "\\`o \\[frame 0\\]\\.some\n" (buffer-string)))))
|
|
|
|
;; A union case's field. The payload sits at an offset that depends on which
|
|
;; case the value is in, and only the renderer knows which it currently holds
|
|
;; — it wrote the head `Shape.circle'. So the case travels with the name.
|
|
(test-flan--check "a union field carries its case on the wire"
|
|
(equal (flan-inspect-wire-step '(:field "r" "Shape.circle"))
|
|
"Shape.circle.r"))
|
|
(test-flan--check "a struct field does not"
|
|
(equal (flan-inspect-wire-step '(:field "x" "V")) "x"))
|
|
(test-flan--check "an element is its number"
|
|
(equal (flan-inspect-wire-step '(:index 2)) 2))
|
|
|
|
|
|
;; And the other half of that pair: under an *expression* root there is no
|
|
;; accessor to send, so RET refuses there rather than sending `(.at s)' for
|
|
;; the checker to reject. A union's fields are reached by `(match ...)' in
|
|
;; the language, which binds names rather than producing a value. It is a
|
|
;; refusal of the parent, not of the value at point — a struct field that
|
|
;; merely *holds* a union is an ordinary accessor and stays enterable.
|
|
(let ((buf (test-flan--inspect "s" "(Shape.circle {.at (V {.x 1 .y 2})})")))
|
|
(with-current-buffer buf
|
|
(goto-char (point-min))
|
|
(flan-inspect-next)
|
|
(test-flan--check "an expression root refuses a union case's field"
|
|
(string-match-p
|
|
"reached by (match"
|
|
(or (test-flan--caught #'flan-inspect-into) "")))))
|
|
|
|
(let ((asked nil))
|
|
(let ((flan-inspect-request-function
|
|
(lambda (form) (push (plist-get form :code) asked)
|
|
(list :status "ok"
|
|
:value "(Cell {.id 1 .s (Shape.circle {.at (V {.x 1 .y 2})})})")))
|
|
(flan-inspect-buffer " *test-inspect*"))
|
|
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
|
|
(save-window-excursion
|
|
(flan-inspect--show '(:expr "c") nil)
|
|
(with-current-buffer " *test-inspect*"
|
|
(goto-char (point-min))
|
|
(flan-inspect-next) (flan-inspect-next) ; .s, which holds the union
|
|
(test-flan--check "but a struct field that merely holds one is enterable"
|
|
(progn (flan-inspect-into) (equal (car asked) "(.s c)")))))))
|
|
|
|
(test-flan--slot
|
|
0 1 "s"
|
|
(lambda (form)
|
|
(if (plist-get form :path)
|
|
(list :status "ok" :type "V" :value "(V {.x 1 .y 2})")
|
|
(list :status "ok" :type "Shape"
|
|
:value "(Shape.circle {.at (V {.x 1 .y 2})})")))
|
|
(lambda ()
|
|
(goto-char (point-min))
|
|
(flan-inspect-next)
|
|
(flan-inspect-into)
|
|
(test-flan--check "RET into a union field names the case it is in"
|
|
(equal (plist-get (car test-flan--asked) :path)
|
|
'("Shape.circle.at")))))
|
|
|
|
;; The daemon is allowed to refuse — a program that resumed, or a frame whose
|
|
;; body was redefined since it was entered — and the refusal has to reach the
|
|
;; person rather than being answered from somewhere else. Being answered from
|
|
;; somewhere else is the bug this root exists to fix, so it is asserted.
|
|
(let ((flan-inspect-request-function
|
|
(lambda (_)
|
|
(list :status "error"
|
|
:message "look's body was redefined since that frame was entered")))
|
|
(flan-inspect-buffer " *test-inspect*"))
|
|
(test-flan--check "a refused slot root says why, and shows nothing"
|
|
(string-match-p
|
|
"redefined"
|
|
(or (test-flan--caught
|
|
(lambda () (flan-inspect-slot 0 1 "p")))
|
|
""))))
|
|
|
|
;; And the structural claim about `l' from the other side: a new root always
|
|
;; starts a fresh stack, so there is never an entry of another kind left
|
|
;; underneath for `l' to land on.
|
|
(let ((flan-inspect-request-function
|
|
(lambda (form) (if (equal (plist-get form :op) "inspect")
|
|
(list :status "ok" :type "i32" :value "7")
|
|
(list :status "ok" :value "9"))))
|
|
(flan-inspect-buffer " *test-inspect*"))
|
|
(save-window-excursion
|
|
(flan-inspect-slot 1 3 "b")
|
|
(flan-inspect "g")
|
|
(with-current-buffer " *test-inspect*"
|
|
(test-flan--check "a new root drops the stack it did not build"
|
|
(null flan-inspect--stack))
|
|
(test-flan--check "and l has nothing to cross back into"
|
|
(string-match-p
|
|
"nothing behind it"
|
|
(or (test-flan--caught #'flan-inspect-pop) ""))))))
|
|
|
|
|
|
;;; 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
|
|
;; Four elements now: the fourth is
|
|
;; the slot's index, which is what `i'
|
|
;; hands to the inspector.
|
|
:locals '(("i" "i32" "7" 0)
|
|
("b" "Blob" "(Blob {.id 7})" 1)))
|
|
(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, and this is the fixture the bug lived in. `i' used
|
|
;; to send the local's *name* to be evaluated, which resolves wherever the
|
|
;; evaluator stands: right on the innermost frame by luck, and on any other
|
|
;; frame a global, another binding of the same name, or nothing — with the
|
|
;; listing right above it showing the frame's own storage and nothing saying
|
|
;; the two disagree. It sends the frame and the slot index now.
|
|
(let ((asked nil))
|
|
(let ((flan-inspect-request-function
|
|
(lambda (form) (push form asked)
|
|
(list :status "ok" :type "Blob" :value "(Blob {.id 7})")))
|
|
(flan-inspect-buffer " *test-inspect*"))
|
|
(with-current-buffer (test-flan--cnr
|
|
(list :condition "Missing" :restarts '("retry")
|
|
:stack (list (list :fn "g" :fetched t
|
|
:locals '(("b" "Blob" "…" 4)))
|
|
(list :fn "f" :fetched t
|
|
:locals '(("b" "Blob" "…" 2))))))
|
|
(goto-char (point-min))
|
|
(search-forward " 1: > f")
|
|
(flan-cnr-toggle-frame)
|
|
(goto-char (point-min))
|
|
(search-forward " 1: v f")
|
|
(search-forward "Blob b")
|
|
(save-window-excursion (flan-cnr-inspect))
|
|
(test-flan--check "`i' on a local inspects it by frame and slot"
|
|
(equal (plist-get (car asked) :op) "inspect"))
|
|
;; The outer frame, and its own slot index — the two facts a name cannot
|
|
;; carry. Frame 1 has a `b' and so does frame 0; sending "b" would have
|
|
;; reached whichever one the evaluator stands in.
|
|
(test-flan--check "naming the frame the listing was drawn from"
|
|
(= 1 (plist-get (car asked) :frame)))
|
|
(test-flan--check "and the slot index that frame's listing gave"
|
|
(= 2 (plist-get (car asked) :slot)))
|
|
(test-flan--check "nothing is evaluated as an expression"
|
|
(null (plist-get (car asked) :code))))))
|
|
|
|
;; `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))))
|
|
|
|
;; The globals section. One section rather than a fold under each frame, and
|
|
;; the fixtures below are what makes that visible: `grid' is touched by two
|
|
;; frames and appears once.
|
|
(let* ((state (list :condition "Boom"
|
|
:restarts '("retry")
|
|
:stack (list (list :fn "sim/inner" :loc "g.flan:12:1")
|
|
(list :fn "main" :loc "g.flan:30:1"))
|
|
;; Ordered as the daemon orders it: by the innermost frame
|
|
;; that touches each one.
|
|
:globals '(("grid" "[4 i32]" "[ 7 5 0 0]" (0 1))
|
|
("pressure" "i64" "12" (0))
|
|
("label" "string" "\"running\"" (1)))))
|
|
(buf (test-flan--cnr state))
|
|
(text (with-current-buffer buf (buffer-string))))
|
|
(test-flan--check "a global is named, typed and valued"
|
|
(string-match-p "pressure +i64 = 12" text))
|
|
(test-flan--check "and it is one section, not one per frame"
|
|
(= 1 (seq-count (lambda (l) (string-match-p "grid" l))
|
|
(split-string text "\n"))))
|
|
;; The annotation is what recovers the half per-frame nesting would have
|
|
;; told you, and it costs no duplication to say it.
|
|
(test-flan--check "a global two frames touch says both"
|
|
(string-match-p "frames 0, 1" text))
|
|
(test-flan--check "and one only the innermost touches says one"
|
|
(string-match-p "frame 0\n" text))
|
|
(test-flan--check "the innermost frame's globals come first"
|
|
(< (string-match "pressure" text) (string-match "label" text)))
|
|
;; `i' reaches a global the same way it reaches a local: a global's name is
|
|
;; an expression the program can be handed, which is the whole trick the
|
|
;; inspector is built on.
|
|
(with-current-buffer buf
|
|
(goto-char (point-min))
|
|
(test-flan--check "and a global line is inspectable, by expression"
|
|
(progn (search-forward "pressure")
|
|
(equal (get-text-property (point) 'flan-cnr-inspect)
|
|
'(:expr "pressure"))))))
|
|
|
|
;; Empty is a claim, not a gap: the section is the union of what the stack
|
|
;; reaches, so nothing in it means the state is all in the locals.
|
|
(let ((text (with-current-buffer
|
|
(test-flan--cnr (list :condition "Boom" :restarts '("retry")
|
|
:stack (list (list :fn "f"))))
|
|
(buffer-string))))
|
|
(test-flan--check "an empty globals section says what empty means"
|
|
(string-match-p "not available.*union of what the frames reach"
|
|
text)))
|
|
|
|
;; A frame the daemon could not attribute makes the union smaller than the real
|
|
;; one, and a list that is short without saying so is the failure this whole
|
|
;; buffer is built to avoid.
|
|
(let ((text (with-current-buffer
|
|
(test-flan--cnr
|
|
(list :condition "Boom" :restarts '("retry")
|
|
:stack (list (list :fn "f"))
|
|
:globals '(("label" "string" "\"x\"" (1)))
|
|
:globals-refused '(("weird" "no printer for (Map i64 i64)"))
|
|
:globals-skipped
|
|
'(("0: sim/inner" "this frame's body was redefined since it was entered"))))
|
|
(buffer-string))))
|
|
(test-flan--check "a global with no printer is refused by name"
|
|
(string-match-p "weird: no printer" text))
|
|
(test-flan--check "an unattributable frame says the union is incomplete"
|
|
(string-match-p "union is incomplete" text))
|
|
(test-flan--check "and names the frame it lost"
|
|
(string-match-p "0: sim/inner" text)))
|
|
|
|
;; The fetch is a function from a reply to data, like the other two, so it is
|
|
;; drivable with no socket.
|
|
(let ((flan-cnr-request-function
|
|
(lambda (_) '(:status "ok"
|
|
:globals (("g" "i64" "1" (0)))
|
|
:refused (("h" "no printer"))
|
|
:skipped (("1: m" "redefined"))))))
|
|
(let ((got (flan-cnr-globals)))
|
|
(test-flan--check "globals come back as entries, refusals and skipped frames"
|
|
(equal got '((("g" "i64" "1" (0)))
|
|
(("h" "no printer"))
|
|
(("1: m" "redefined")))))))
|
|
|
|
(let ((flan-cnr-request-function (lambda (_) '(:status "error" :message "running"))))
|
|
(test-flan--check "and a refusal is nil, not an error"
|
|
(null (flan-cnr-globals))))
|
|
|
|
(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)
|
|
|
|
;; Ghost text, which is the same kind of thing: rows in, overlays out, and the
|
|
;; buffer it reads is a fixture like any other reply here. Loaded for the same
|
|
;; reason.
|
|
(load (expand-file-name "test-flan-watch.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
|