JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/emacs/test-flan-cider.el

2059 lines
103 KiB
EmacsLisp
Raw Blame History

;;; 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--auto-break', which is a decision about globals and windows
;; and needs neither a daemon nor a socket to be asked.
(require 'flan)
(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 the worked example in docs/BUILT.md, "`C-x C-e` — evaluating
;; an expression", 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))
(test-flan--check "an expression's value has no address line"
(not (string-match-p "^at 0x" text)))))
;; Where a slot's value is stored, which the slot root's reply carries: under
;; the value, in hex.
(let ((flan-inspect-request-function
(lambda (_) '(:status "ok" :type "i32" :value "7" :addr 140737488345360)))
(flan-inspect-buffer " *test-inspect*"))
(let ((text (with-current-buffer
(save-window-excursion (flan-inspect-slot 1 0 "n"))
(buffer-string))))
(test-flan--check "a slot's value says where it is stored"
(string-match-p "^at 0x7FFFFFFFD910$" 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 address root, and the registry listings
(message "\nthe address root")
;; The rooting mode with no frame in it. What is asserted here is the *wire*:
;; the buffer sends `at' with the address, sends `:type' only when one was
;; named, and refuses a path rather than dropping it. What the daemon does
;; with that is test_dev.ml's business, over a real program.
(let* ((sent nil)
(flan-inspect-request-function
(lambda (form) (setq sent form) '(:status "ok" :value "<ptr (Enemy {.hp 41 .x 2})>"
:type "(Ptr Enemy)" :live t :recorded "Enemy")))
(flan-inspect-buffer " *test-inspect*"))
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
(let ((text (with-current-buffer
(save-window-excursion
(flan-inspect--show (list :addr 4096 nil) nil))
(buffer-string))))
(test-flan--check "an address root asks the daemon for `at'"
(equal (plist-get sent :op) "at"))
(test-flan--check "with the address"
(equal (plist-get sent :addr) 4096))
;; Absent and not empty: leaving it out is what makes the registry answer
;; for the type, which is the whole of what the address root buys.
(test-flan--check "and no :type when none was named"
(null (plist-get sent :type)))
(test-flan--check "the address is named in hex at the top"
(string-match-p "#x1000" text))))
(let* ((sent nil)
(flan-inspect-request-function
(lambda (form) (setq sent form) '(:status "ok" :value "<ptr 41>" :type "(Ptr i32)")))
(flan-inspect-buffer " *test-inspect*"))
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
(let ((text (with-current-buffer
(save-window-excursion
(flan-inspect--show (list :addr 4096 "i32") nil))
(buffer-string))))
(test-flan--check "a named type is sent as :type"
(equal (plist-get sent :type) "i32"))
(test-flan--check "and shown beside the address"
(string-match-p "#x1000 as i32" text))))
;; A path is refused rather than dropped. A path with a step silently gone
;; would render a different value and say nothing, which is the failure the
;; whole buffer is built to avoid.
(let ((flan-inspect-request-function
(lambda (_) '(:status "ok" :value "<ptr 41>"))))
(test-flan--check "an address root refuses a path"
(eq 'caught
(condition-case nil
(flan-inspect--value (list :addr 4096 nil) '((:field "x")))
(user-error 'caught)))))
;; And a followed pointer is refused for the true reason rather than for "no
;; structure": it has structure, it is drawn, and the step would be a second
;; deref nobody asked about.
(test-flan--check "a followed pointer says why it cannot be entered"
(string-match-p
"second deref"
(flan-inspect-refusal
(flan-inspect-parse "<ptr (Enemy {.hp 41 .x 2})>"))))
(message "\nthe registry listings")
(let* ((sent nil)
(flan--request-stub
(lambda (form)
(setq sent form)
'(:status "ok"
:types (("Enemy" 2 64) ("i32" 1 16))
:blocks 3 :bytes 80 :overflow nil
:note "every block the registry recorded"))))
(cl-letf (((symbol-function 'flan--request) flan--request-stub)
((symbol-function 'display-buffer) #'ignore))
(let ((flan-allocations-buffer " *test-allocations*"))
(flan-allocations)
(test-flan--check "the breakdown asks for `allocations'"
(equal (plist-get sent :op) "allocations"))
(let ((text (with-current-buffer " *test-allocations*" (buffer-string))))
(test-flan--check "and lists each type with its blocks and bytes"
(string-match-p "2 +64 +Enemy" text))
(test-flan--check "with a total under it"
(string-match-p "3 +80 +in 2 types" text)))
(flan-leaks)
(test-flan--check "the leak report asks for `leaks'"
(equal (plist-get sent :op) "leaks"))
(kill-buffer " *test-allocations*"))))
;; An overflowed table has blocks in the program that are in nobody's row, so
;; every number under it is a floor. Said before the numbers, because a reader
;; who missed it would quote them as counts.
(cl-letf (((symbol-function 'flan--request)
(lambda (_) '(:status "ok" :types (("Enemy" 1 32)) :blocks 1 :bytes 32
:overflow t)))
((symbol-function 'display-buffer) #'ignore))
(let ((flan-allocations-buffer " *test-allocations*"))
(flan-allocations)
(let ((text (with-current-buffer " *test-allocations*" (buffer-string))))
(test-flan--check "an overflowed table is said to be a floor"
(string-match-p "floors, not counts" text)))
(kill-buffer " *test-allocations*")))
;; And a release build, which records nothing and says so. The refusal comes
;; back as an ordinary error status and reaches the person, rather than an
;; empty listing that reads like a program holding nothing.
(cl-letf (((symbol-function 'flan--request)
(lambda (_) '(:status "error"
:message "the allocation registry is off; this is not a dev build")))
((symbol-function 'display-buffer) #'ignore))
(test-flan--check "a build with no registry refuses rather than showing nothing"
(eq 'caught
(condition-case nil (flan-leaks) (user-error 'caught)))))
;;; 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 data type 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 data type 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 data type'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 data type 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 data type 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 data type
(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 data type 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) ""))))))
;;; Writing one back
(message "\nsetting a value, and the buffer as the value")
(defun test-flan--writable (value &optional type replies body)
"Open a slot root on VALUE, at a stop, and run BODY in its buffer.
The stop number is what makes the buffer writable at all, so it is in the
fixture rather than in each test: a reply without one is a reply from a read
the daemon could not date, and this helper is for the case where it could."
(test-flan--slot
1 0 "b"
(or replies
(lambda (form)
(if (equal (plist-get form :op) "set")
(list :status "ok" :type (or type "Blob") :value value :at-stop 7
:wrote 1)
(list :status "ok" :type (or type "Blob") :value value :at-stop 7))))
body))
;; The two refusals that come before any request: a root that names no frame,
;; and a drawing that names no stop. Both are refusals of *this buffer*
;; rather than of the value in it, and both say which root can.
(let ((flan-inspect-request-function
(lambda (_) (list :status "ok" :value "7" :type "i32")))
(flan-inspect-buffer " *test-inspect*"))
(save-window-excursion
(flan-inspect "g")
(with-current-buffer " *test-inspect*"
(test-flan--check "an expression root cannot be written to"
(string-match-p
"roots at a frame's slot"
(or (test-flan--caught #'flan-inspect-set) "")))
(test-flan--check "and neither can an address root, for the same reason"
(progn
(flan-inspect-address 4096 nil)
(string-match-p
"roots at a frame's slot"
(or (test-flan--caught #'flan-inspect-set) "")))))))
(test-flan--slot
1 0 "b"
(lambda (_) (list :status "ok" :type "i32" :value "7"))
(lambda ()
(test-flan--check "a slot root the daemon did not date cannot be written to"
(string-match-p
"name the stop"
(or (test-flan--caught #'flan-inspect-set) "")))
(test-flan--check "and the legend does not offer keys that would refuse"
(not (string-match-p "e set" (buffer-string))))))
;; `e' on a field line. What is sent is the buffer's own path with the line's
;; step on the end, the stop the drawing was made at, and the expression typed
;; — not a value the client converted into anything.
(test-flan--writable
"(Blob {.id 7 .name \"sandy\"})" "Blob" nil
(lambda ()
(test-flan--check "the legend offers the write keys where they work"
(string-match-p "e set" (buffer-string)))
(goto-char (point-min))
(flan-inspect-next) ; .id
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "(+ 1 2)")))
(flan-inspect-set))
(let ((sent (car (last test-flan--asked 2))))
(test-flan--check "e sends a set"
(equal (plist-get sent :op) "set"))
(test-flan--check "rooted at the frame and slot the buffer is on"
(and (equal (plist-get sent :frame) 1)
(equal (plist-get sent :slot) 0)))
(test-flan--check "naming the stop the drawing was made at"
(equal (plist-get sent :at-stop) 7))
(test-flan--check "with one edit, at the field the line names"
(equal (plist-get sent :edits)
'((:code "(+ 1 2)" :path ("id")))))
(test-flan--check "and the expression is sent as it was typed"
(equal (plist-get (car (plist-get sent :edits)) :code)
"(+ 1 2)")))
(test-flan--check "and the buffer is drawn again from a fresh read"
(equal (plist-get (car test-flan--asked) :op) "inspect"))))
;; The prompt offers what is there, so the common edit is a character.
(test-flan--writable
"(Blob {.id 7 .name \"sandy\"})" "Blob" nil
(lambda ()
(goto-char (point-min))
(flan-inspect-next) (flan-inspect-next) ; .name
(let ((offered nil))
(cl-letf (((symbol-function 'read-string)
(lambda (_ &optional init &rest _r) (setq offered init) "\"sandy2\"")))
(flan-inspect-set))
(test-flan--check "the prompt starts from what is there now"
(equal offered "\"sandy\"")))))
;; Point on nothing in particular sets the whole value, which is how a data
;; type's case is changed and how anything the field list cannot reach is.
(test-flan--writable
"(Blob {.id 7})" "Blob" nil
(lambda ()
(goto-char (point-min))
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "(Blob {.id 9})")))
(flan-inspect-set))
(let ((sent (car (last test-flan--asked 2))))
(test-flan--check "point off a field line sets the whole value"
(equal (plist-get sent :edits)
'((:code "(Blob {.id 9})")))))))
;; A refusal from the daemon reaches the person and changes nothing. The
;; refusals that matter here are the daemon's own — a type that does not fit,
;; a stop that has moved — and this end must not paper over either.
(test-flan--writable
"(Blob {.id 7})" "Blob"
(lambda (form)
(if (equal (plist-get form :op) "set")
(list :status "error" :message "expected i32, found string")
(list :status "ok" :type "Blob" :value "(Blob {.id 7})" :at-stop 7)))
(lambda ()
(goto-char (point-min))
(flan-inspect-next)
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "\"no\"")))
(test-flan--check "the checker's refusal reaches the person"
(string-match-p
"expected i32, found string"
(or (test-flan--caught #'flan-inspect-set) ""))))))
(test-flan--writable
"(Blob {.id 7})" "Blob"
(lambda (form)
(if (equal (plist-get form :op) "set")
(list :status "error"
:message "this was written against stop 7 and the program is at \
stop 9 now: it ran on and stopped again, so what is on the screen is not what \
would be overwritten. Look again and re-do the edit")
(list :status "ok" :type "Blob" :value "(Blob {.id 7})" :at-stop 7)))
(lambda ()
(goto-char (point-min))
(flan-inspect-next)
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "9")))
(test-flan--check "a stale drawing is refused with what to do about it"
(string-match-p
"Look again"
(or (test-flan--caught #'flan-inspect-set) ""))))))
;;; The buffer as the value
;; The literal the editable buffer holds is the value's own spelling, and it
;; has to read back as what it was written from — otherwise a commit would
;; diff a parse against a different parse and see changes nobody made.
(let ((round
(lambda (s)
(equal (flan-inspect-parse s)
(flan-inspect-parse
(flan-inspect--literal (flan-inspect-parse s)))))))
(test-flan--check "a struct round-trips through the editable spelling"
(funcall round "(Blob {.id 7 .name \"sandy\" .pos (V {.x 1.5 .y 0})})"))
(test-flan--check "an array does too"
(funcall round "[ 10 20 30]"))
(test-flan--check "and an option, and a nested one"
(funcall round "(some (V {.x 1 .y (some 2)}))")))
(let ((old (flan-inspect-parse "(Blob {.id 7 .name \"sandy\" .pos (V {.x 1.5 .y 0})})")))
;; One leaf changed is one edit, with the steps that reach it and nothing
;; else — the whole point of diffing rather than writing the value back.
(let ((d (flan-inspect--diff
old
(flan-inspect-parse
"(Blob {.id 7 .name \"sandy\" .pos (V {.x 2.5 .y 0})})"))))
(test-flan--check "one changed leaf is one edit"
(equal (car d) '((((:field "pos" "Blob") (:field "x" "V")) . "2.5"))))
(test-flan--check "and nothing is refused about it" (null (cdr d))))
(let ((d (flan-inspect--diff
old
(flan-inspect-parse
"(Blob {.id 8 .name \"tuned\" .pos (V {.x 1.5 .y 0})})"))))
(test-flan--check "two changed leaves are two edits, and only two"
(equal (car d)
'((((:field "id" "Blob")) . "8")
(((:field "name" "Blob")) . "\"tuned\"")))))
(let ((d (flan-inspect--diff old (flan-inspect-parse "(Blob {.id 7 .name \"sandy\" .pos (V {.x 1.5 .y 0})})"))))
(test-flan--check "an untouched value is no edits at all"
(and (null (car d)) (null (cdr d)))))
;; And the shapes that are not stores. Each is refused whole, so the leaf
;; that did line up beside it does not go either.
(let ((d (flan-inspect--diff
old
(flan-inspect-parse
"(Blob {.id 8 .name \"sandy\" .pos 3})"))))
(test-flan--check "a leaf where a struct was is refused, not written"
(and (null (car d)) (string-match-p "kind of thing" (cdr d)))))
(let ((d (flan-inspect--diff
old
(flan-inspect-parse "(Blob {.id 7 .name \"sandy\"})"))))
(test-flan--check "a field removed is refused by name"
(and (null (car d))
(string-match-p "does not add or rename" (cdr d))))))
(let ((d (flan-inspect--diff (flan-inspect-parse "[ 1 2 3]")
(flan-inspect-parse "[ 1 2 3 4]"))))
(test-flan--check "an element added is a change to the container, and refused"
(and (null (car d))
(string-match-p "3 elements and the buffer has 4" (cdr d)))))
(let ((d (flan-inspect--diff
(flan-inspect-parse "(Shape.circle {.r 1})")
(flan-inspect-parse "(Shape.square {.r 1})"))))
(test-flan--check "a data type's case is the tag, so it is not a field edit"
(and (null (car d)) (string-match-p "set whole" (cdr d)))))
(let ((d (flan-inspect--diff (flan-inspect-parse "(B {.p <ptr>})")
(flan-inspect-parse "(B {.p 4096})"))))
(test-flan--check "typing over what the renderer did not write is refused"
(and (null (car d)) (string-match-p "nothing there" (cdr d)))))
;; The truncation guard. A value the renderer stopped short of is one where
;; some of the fields are simply absent from the buffer, and a commit read off
;; it could not tell them from fields somebody deleted.
(test-flan--writable
"(Blob {.id 7 .deep (V {.a (W {.b ...})})})" "Blob" nil
(lambda ()
(test-flan--check "a truncated value refuses to be opened for editing"
(string-match-p
"never written"
(or (test-flan--caught #'flan-inspect-edit) "")))))
;; And the whole round trip: open, edit the text, commit, and what goes out is
;; one write for the leaf that changed.
(test-flan--writable
"(Blob {.id 7 .name \"sandy\"})" "Blob" nil
(lambda ()
(flan-inspect-edit)
(test-flan--check "editing shows the value as a Flan literal"
(string-match-p "(Blob {" (buffer-string)))
(test-flan--check "and says how to commit it"
(string-match-p "C-c C-c commits" (buffer-string)))
(test-flan--check "a commit with nothing changed says so"
(string-match-p
"nothing in the buffer differs"
(or (test-flan--caught #'flan-inspect-commit) "")))
(goto-char (point-min))
(search-forward ".id 7")
(replace-match ".id 42")
(flan-inspect-commit)
(let ((sent (car (last test-flan--asked 2))))
(test-flan--check "the commit writes the one leaf that changed"
(equal (plist-get sent :edits)
'((:code "42" :path ("id")))))
(test-flan--check "and names the stop the buffer was drawn at"
(equal (plist-get sent :at-stop) 7)))
(test-flan--check "and the buffer is a listing again afterwards"
(not flan-inspect--editing))))
(test-flan--writable
"(Blob {.id 7})" "Blob" nil
(lambda ()
(flan-inspect-edit)
(goto-char (point-max))
(insert "junk (")
(test-flan--check "an edit that has stopped being a value refuses whole"
(let ((why (test-flan--caught #'flan-inspect-commit)))
;; It reads as *something*, but not as the same shape,
;; which is the refusal that names what changed.
(and why (not (string-match-p "wrote" why)))))
(flan-inspect-abandon)
(test-flan--check "and abandoning draws what the program holds"
(and (not flan-inspect--editing)
(string-match-p "\\.id +7" (buffer-string))))
;; The listing is read-only again, and that is the assertion rather than
;; the flag: the flag says which mode the buffer is in, this says whether
;; `C-k' on a line of the listing would do something.
(test-flan--check "and the listing is read-only again afterwards"
buffer-read-only)))
(test-flan--writable
"(Blob {.id 7})" "Blob" nil
(lambda ()
(test-flan--check "committing a listing says it is not an edit"
(string-match-p
"C-c C-e"
(or (test-flan--caught #'flan-inspect-commit) "")))))
;;; 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 other two facts about a row, which nothing here can work out and both
;; come off the reply.
(let ((rows (flan-cnr-annotate-restarts
'("retry" "abandon-evaluation" "continue") '(2) 1)))
(test-flan--check "the position the reply named is the one that abandons"
(eq (nth 3 (nth 1 rows)) 'abandon))
(test-flan--check "a position the program will refuse is marked unreachable"
(eq (nth 3 (nth 2 rows)) 'unreachable))
(test-flan--check "and an ordinary restart is neither"
(null (nth 3 (nth 0 rows)))))
;; At a trap the reason is a different reason, and it is the break's rather
;; than any entry's: there is no transfer channel, so nothing can be taken and
;; there is no evaluation to be below.
(let ((rows (flan-cnr-annotate-restarts '("continue" "abandon-evaluation")
'(0 1) nil t)))
(test-flan--check "a trap marks every row with the trap's own reason"
(equal (mapcar (lambda (r) (nth 3 r)) rows)
'(trapped trapped)))
(test-flan--check "and the boundary is not exempt from it"
(eq (nth 3 (nth 1 rows)) 'trapped)))
;; By position, never by name. A program may establish a restart called
;; `abandon-evaluation' of its own, and offering that as the way out of an
;; evaluation would promise an unwind nobody can make.
(let ((rows (flan-cnr-annotate-restarts '("abandon-evaluation") nil nil)))
(test-flan--check "a program's own restart of that name is not the boundary"
(null (nth 3 (nth 0 rows)))))
;;; 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 whose name it repeats"
(string-match-p "same name as 0" 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 — no struct" 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" (and (string-match-p "TAB fold" text)
(string-match-p "P prelude frames" text))))
;; The runtime's sentence sits under the name. At a trap it is all there is:
;; a trap is not a struct, so the fields section says why it is empty rather
;; than that no struct has the name.
(let ((text (with-current-buffer
(test-flan--cnr
(list :condition "ArithError"
:sentence "divide by zero: (/ 10 0)"
:restarts '("continue")))
(buffer-string))))
(test-flan--check "the runtime's sentence is under the condition's name"
(string-match-p "\\`ArithError\ndivide by zero: (/ 10 0)\n" text)))
(let ((text (with-current-buffer
(test-flan--cnr
(list :condition "DynType" :trap t
:sentence "dyn +: int and text, and + wants two numbers — (+ 3 \"hi\")"
:restarts nil))
(buffer-string))))
(test-flan--check "a trap's sentence is shown"
(string-match-p "and \\+ wants two numbers" text))
(test-flan--check "and its missing fields are not called a missing struct"
(string-match-p "a trap carries no fields" text)))
;; What a restart says beside its name: its `:report' sentence, the types it
;; takes, and where its clause is written — and `v' on the row visits that.
(let* ((buf (test-flan--cnr
(list :condition "FileError"
:restarts '("retry" "use-value" "plain")
:details '((:report "Try the file operation again"
:at "/src/files.flan:12:3" :arity 0 :params "()")
(:report "Try again with another path"
:at "/src/files.flan:12:3" :arity 1
:params "(string)")
(:report "" :at nil :arity 0 :params "()")))))
(text (with-current-buffer buf (buffer-string))))
(test-flan--check "a restart's report is beside its name"
(string-match-p "\\[retry\\] +Try the file operation again" text))
(test-flan--check "and where its clause is written"
(string-match-p "again (/src/files.flan:12:3)" text))
(test-flan--check "a restart taking values shows their types"
(string-match-p "\\[use-value\\] +(string) Try again with another path"
text))
(test-flan--check "one with no report and no source shows its name alone"
(string-match-p " 2: \\[plain\\] *\n" text))
(let ((visited nil))
(cl-letf (((symbol-function 'flan-visit-loc)
(lambda (loc subject) (setq visited (list loc subject)))))
(with-current-buffer buf
(goto-char (point-min))
(search-forward " 1: ")
(flan-cnr-visit)))
(test-flan--check "v on a restart visits its clause"
(equal visited '("/src/files.flan:12:3" "restart use-value")))))
;; A restart that takes values asks for one per parameter and sends them.
(test-flan--check "a restart's parameter types are read from their spelling"
(equal (flan-cnr-param-types "(i64 (Option string))")
'("i64" "(Option string)")))
(let ((sent nil) (asked nil))
(let ((flan-cnr-request-function
(lambda (form) (setq sent form) (list :status "ok" :note "accepted"))))
(cl-letf (((symbol-function 'read-string)
(lambda (prompt &rest _) (push prompt asked) "(+ 40 2)")))
(with-current-buffer
(test-flan--cnr
(list :condition "ArithError" :restarts '("use-value")
:details '((:report "" :at nil :arity 1 :params "(i64)"))))
(goto-char (point-min))
(search-forward " 0: ")
(save-window-excursion (flan-cnr-take)))))
(test-flan--check "taking a typed restart asks for its value by type"
(equal asked '("use-value, a value of type i64: ")))
(test-flan--check "and sends it as :args"
(equal sent '(:op "restart-at" :index 0 :name "use-value"
:args ("(+ 40 2)")))))
;; 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-at' with the index, and the name as a receipt:
;; the index is the identity — two frames can offer `retry' — and the name is
;; what lets the daemon refuse a buffer that has gone stale.
(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 index, name as receipt"
(equal sent '(:op "restart-at" :index 1 :name "skip"))))))
;; And a shadowed one is *takeable* now — the choice goes out by number, so
;; the inner frame owning the name no longer matters. This is the bug
;; `completing-read' had: it sent "retry" and the inner frame took it,
;; silently.
(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" "a" "retry")))
(goto-char (point-min))
(search-forward " 2: ")
(save-window-excursion (flan-cnr-take))
(test-flan--check "a shadowed restart is taken by its own index"
(equal sent '(:op "restart-at" :index 2 :name "retry"))))))
;; 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-at" :index 0 :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"))))))
;; A break inside an evaluation: one restart drops the expression, one belongs
;; to the program below and cannot be taken. Both are drawn, and each says
;; which it is — a row that cannot be taken is shown rather than hidden,
;; because "where did my restart go" is a fair question.
(let ((text (with-current-buffer
(test-flan--cnr
(list :condition "BoundsError"
:restarts '("abandon-evaluation" "continue")
:unreachable '(1)
:abandon 0))
(buffer-string))))
(test-flan--check "the way out of an evaluation says what it does"
(string-match-p "0: \\[abandon-evaluation\\] *stop running this expression"
text))
(test-flan--check "and says what it does not undo"
(string-match-p "already changed stays changed" text))
(test-flan--check "a restart below the evaluation loses its bracket"
(string-match-p " 1: continue " text))
(test-flan--check "and says why it cannot be taken"
(string-match-p "nowhere to land" text))
(test-flan--check "abort is still last, and still one past the restarts"
(string-match-p " 2: \\[abort\\]" text)))
;; Point starts on it, because after a C-x C-e that went wrong this is the
;; answer nine times in ten. The list itself is not reordered: the number
;; beside a restart is the program's own index.
(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 "BoundsError"
:restarts '("retry" "abandon-evaluation")
:abandon 1))
(save-window-excursion (flan-cnr-take))
(test-flan--check "RET with point where it was left abandons the evaluation"
(equal sent
'(:op "restart-at" :index 1
:name "abandon-evaluation"))))))
;; And the half of the report that was a silence: a choice that cannot be
;; taken has to *say* so. Refused here rather than sent and refused there,
;; with the same sentence either way.
(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 "BoundsError"
:restarts '("abandon-evaluation" "continue")
:unreachable '(1)
:abandon 0))
;; `let*': the digit is read out of `last-command-event' by the command
;; itself, so it has to be bound before the thunk runs and not beside it.
(let* ((last-command-event ?1)
(msg (test-flan--caught
(lambda ()
(call-interactively #'flan-cnr-take-number)))))
(test-flan--check "a digit on an unreachable restart is refused out loud"
(and msg (string-match-p "nowhere to land" msg)))
(test-flan--check "and nothing was sent for it"
(null sent))))))
;; And the same break drawn at a trap: every row refused, and refused for the
;; trap's reason. The wrong reason here is the one a user meets first in the
;; segfault break — "below this evaluation" about a break that is not inside
;; one, with nothing offered to abandon.
(let ((text (with-current-buffer
(test-flan--cnr
(list :condition "SIGSEGV"
:restarts '("continue")
:unreachable '(0)
:abandon nil
:trap t))
(buffer-string))))
(test-flan--check "a trap's rows say the trap has no transfer channel"
(string-match-p "no transfer channel" text))
(test-flan--check "and say nothing about an evaluation that is not there"
(not (string-match-p "below this evaluation" text))))
(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 "SIGSEGV"
:restarts '("continue")
:unreachable '(0)
:trap t))
(let* ((last-command-event ?0)
(msg (test-flan--caught
(lambda ()
(call-interactively #'flan-cnr-take-number)))))
(test-flan--check "a digit at a trap is refused with the trap's reason"
(and msg (string-match-p "no transfer channel" msg)))
(test-flan--check "and not with the evaluation's"
(and msg (not (string-match-p "abandon" msg))))
(test-flan--check "nothing was sent for it either" (null sent))))))
;; 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 prelude's frames, and the source behind a frame. `(pause)' is a prelude
;; function, so the innermost frame of every breakpoint is the prelude's own and
;; not a step of the program. It is hidden and keeps its number, because the
;; number is what `locals' and the inspector are asked by.
(let* ((dir (make-temp-file "flan-cnr-src" t))
(src (expand-file-name "game.flan" dir)))
(with-temp-file src
(insert "(defn tick [] ()\n (pause))\n\n(defn main [] ()\n (tick))\n"))
(let* ((state (list :condition "Pause" :restarts '("continue")
:site (format "%s:2:3" src) :source " (pause))"
:stack (list (list :fn "pause" :loc "<prelude>:151:7"
:fetched t :locals nil)
(list :fn "tick" :loc (format "%s:1:1" src)
:fetched t :locals nil)
(list :fn "main" :loc (format "%s:4:1" src)
:fetched t :locals nil))))
(buf (test-flan--cnr state)))
(with-current-buffer buf
(setq flan-cnr--show-prelude nil)
(flan-cnr--render state)
(let ((text (buffer-string)))
(test-flan--check "a prelude frame is hidden to begin with"
(not (string-match-p "0: > pause" text)))
(test-flan--check "and a line in its place says so"
(string-match-p "1 prelude frame hidden — P shows it" text))
(test-flan--check "the program's frames keep their numbers"
(and (string-match-p " 1: > tick" text)
(string-match-p " 2: > main" text))))
(goto-char (point-min))
(search-forward "prelude frame hidden")
(flan-cnr-take)
(test-flan--check "RET on that line shows the prelude frames"
(string-match-p " 0: > pause +<prelude>:151:7"
(buffer-string)))
(goto-char (point-min))
(search-forward " 0: > pause")
(let ((msg (test-flan--caught #'flan-cnr-visit)))
(test-flan--check "visiting a prelude frame refuses, naming the prelude"
(and msg (string-match-p "<prelude>, which is not a file" msg))))
(flan-cnr-toggle-prelude)
(test-flan--check "and P hides them again"
(not (string-match-p "0: > pause" (buffer-string))))
;; RET on a frame goes to its location.
(goto-char (point-min))
(search-forward " 2: > main")
(save-window-excursion
(let ((visited (progn (flan-cnr-take) (current-buffer))))
(test-flan--check "RET on a frame visits its source"
(equal (buffer-file-name visited) src))
(test-flan--check "at the frame's line"
(= (line-number-at-pos) 4))
(kill-buffer visited)))
(test-flan--check "RET on a frame no longer folds it"
(not (memq 2 flan-cnr--open)))
;; next-error: the stop first, then each frame with a file behind it.
(test-flan--check "the break buffer is a next-error buffer"
(eq next-error-function #'flan-cnr-next-error))
(let ((lines nil))
(save-window-excursion
(with-current-buffer buf
(goto-char (point-min))
(dotimes (k 3)
(let ((b (flan-cnr-next-error 1 (zerop k))))
(push (with-current-buffer b (line-number-at-pos)) lines)
(set-buffer buf)))
(test-flan--check "and past the last frame it says so"
(test-flan--caught
(lambda () (flan-cnr-next-error 1))))
(flan-cnr-next-error -1)
(test-flan--check "and walks back"
(= (line-number-at-pos) 1))))
(test-flan--check "next-error walks the stop, then tick, then main"
(equal (nreverse lines) '(2 1 4))))
(let ((b (get-file-buffer src))) (when b (kill-buffer b))))
(delete-directory dir t)))
;; A stop raised inside a prelude function is shown where it stopped: the
;; innermost frame stays even though it is the prelude's, and the prelude
;; frames further out are still hidden. `(pause)' is the exception, above.
(let ((text (with-current-buffer
(test-flan--cnr
(list :condition "BoundsError" :restarts nil
:stack (list (list :fn "sum" :loc "<prelude>:40:3")
(list :fn "fold" :loc "<prelude>:12:1")
(list :fn "main" :loc "/g.flan:3:1"))))
(buffer-string))))
(test-flan--check "a prelude frame that stopped is shown"
(string-match-p " 0: > sum" text))
(test-flan--check "and the prelude frames outside it are hidden"
(and (not (string-match-p " 1: > fold" text))
(string-match-p "1 prelude frame hidden" text))))
;; Once a restart or an abort is accepted the stack is gone, and `next-error'
;; from a source buffer must stop walking it.
(dolist (how '(restart abort))
(let* ((flan-cnr-request-function (lambda (_) '(:status "ok")))
(buf (test-flan--cnr (list :condition "Missing" :restarts '("retry")
:stack (list (list :fn "f" :loc "/x.flan:1:1"))))))
(setq next-error-last-buffer buf)
(with-current-buffer buf
(save-window-excursion
(if (eq how 'abort) (flan-cnr-abort)
(goto-char (point-min))
(search-forward "retry")
(flan-cnr-take))))
(test-flan--check (format "after the %s, next-error no longer walks the stack" how)
(null next-error-last-buffer))))
;; And the same when the program resumed some other way: the break buffer is
;; forgotten, and any other next-error buffer is left alone.
(let ((flan-cnr-buffer " *test-cnr*")
(other (get-buffer-create " *test-other-errors*")))
(setq next-error-last-buffer (get-buffer " *test-cnr*"))
(flan--forget-break-stack)
(test-flan--check "a resume forgets the break buffer as the next-error buffer"
(null next-error-last-buffer))
(setq next-error-last-buffer other)
(flan--forget-break-stack)
(test-flan--check "and leaves a compilation's alone"
(eq next-error-last-buffer other))
(setq next-error-last-buffer nil)
(kill-buffer other))
;; 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))))))
;; `e' evaluates in the frame point is on, or on a local of: the request
;; names that frame, and the value comes back to the echo area.
(let* ((asked nil)
(flan-cnr-request-function
(lambda (form) (push form asked) '(:status "ok" :value "8"))))
(with-current-buffer (test-flan--cnr
(list :condition "Missing" :restarts '("retry")
:stack (list (list :fn "g" :fetched t
:locals '(("b" "i64" "1" 4)))
(list :fn "f" :fetched t
:locals '(("n" "i64" "7" 0))))))
(goto-char (point-min))
(search-forward " 1: > f")
(flan-cnr-toggle-frame)
(goto-char (point-min))
(search-forward " 1: v f")
(search-forward "i64 n")
(let ((said (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "(+ n 1)"))
((symbol-function 'message)
(lambda (fmt &rest args) (apply #'format fmt args))))
(call-interactively #'flan-cnr-eval-in-frame))))
(test-flan--check "`e' on a local evaluates in that local's frame"
(and (equal (plist-get (car asked) :op) "eval-expr")
(= 1 (plist-get (car asked) :frame))
(equal (plist-get (car asked) :code) "(+ n 1)")))
(test-flan--check "and answers the value"
(equal said "8")))
(test-flan--check "`e' is the break buffer's own key"
(eq (lookup-key flan-cnr-mode-map "e") #'flan-cnr-eval-in-frame))))
;; `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"))
:fields-why "the stop's value was not readable"))
(buffer-string))))
(test-flan--check "a field is named and typed even with no value"
(string-match-p ":path *string *not read" text))
(test-flan--check "and the reason is one sentence, said once above the rows"
(and (string-match-p "not read — the stop's value" text)
(= 1 (seq-count
(lambda (l) (string-match-p "not read — " l))
(split-string text "\n")))))
(test-flan--check "a value that is there is simply shown"
(string-match-p ":tried *i32 *3" text))
;; The headline reads the condition's own numbers, so what happened is the
;; first line rather than something assembled from the fields below.
(test-flan--check "the headline carries the fields that have values"
(string-match-p "\\`Missing — tried 3" text)))
;; The whole point of the `condition' verb: values beside the shape, read out
;; of the stopped program by a thunk the daemon builds, with nothing
;; special-casing any one condition type.
(let ((text (with-current-buffer
(test-flan--cnr
(list :condition "BoundsError"
:restarts '("continue")
:fields '(("low" "i64" "648") ("high" "i64" "648")
("length" "i64" "100"))
:site "/home/x/sand.flan:52:13"
:source " (set (at grid i) 1)"))
(buffer-string))))
(test-flan--check "the headline is the condition's own numbers"
(string-match-p "\\`BoundsError — low 648, high 648, length 100"
text))
(test-flan--check "the site is under the headline"
(string-match-p "at /home/x/sand.flan:52:13" text))
(test-flan--check "with the source line"
(string-match-p " 52| +(set (at grid i) 1)" text))
(test-flan--check "and a caret under the column"
(string-match-p "\n +\\^\n" text))
(test-flan--check "every field renders with its value"
(string-match-p ":length +i64 +100" text)))
;; A condition that declares no fields is an ordinary thing — Pause is one —
;; and saying "no struct has this name" about it would be false. The two
;; empties are told apart by the daemon's own count, not inferred from a list
;; that is empty in both cases.
(let ((text (with-current-buffer
(test-flan--cnr (list :condition "Pause" :restarts '("continue")
:fields nil :fields-empty t))
(buffer-string))))
(test-flan--check "a condition with no fields says so"
(string-match-p "this condition has no fields" text))
(test-flan--check "and is not reported as an unknown name"
(not (string-match-p "no struct has this name" text))))
(let ((text (with-current-buffer
(test-flan--cnr (list :condition "Whatsit" :restarts '("continue")
:fields nil))
(buffer-string))))
(test-flan--check "while a name with no struct behind it still says that"
(string-match-p "not available — no struct has this name" text)))
;; A tab-indented source line: the caret pads with the line's own whitespace,
;; so it lands under the column rather than a tab stop away from it.
(let ((text (with-current-buffer
(test-flan--cnr
(list :condition "BoundsError" :restarts nil
:fields '(("low" "i64" "9"))
:site "/x/t.flan:3:9"
:source "\t\t(at g i)"))
(buffer-string))))
;; Six spaces for the " 3| " gutter, then the line's own two tabs, then
;; six spaces for "(at g " — the caret lands under column 9 whatever the
;; tab stop is.
(test-flan--check "the caret pads with the source's own tabs"
(string-match-p "\n \\{6\\}\t\t \\{6\\}\\^\n" text)))
;; No implementation note ever prints: the bracketed design asides used to
;; leak into the buffer, and the fix is pinned as a property of the whole
;; rendering rather than of one string.
(let ((text (with-current-buffer
(test-flan--cnr
(list :condition "Missing" :restarts '("retry" "a" "retry")
:fields '(("path" "string" nil))
:stack (list (list :fn "f" :fetched t :locals nil))))
(buffer-string))))
(test-flan--check "no bracketed implementation note leaks into the buffer"
(not (string-match-p "\\[needs\\|agent verb\\|Tast\\." 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 this stub's
;; daemon answers only the first — so the values fall back to the
;; layout, each row saying in one sentence why it is empty.
(test-flan--check "and every value still says why it is missing"
(string-match-p ":tried *i32 *not read" 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 — .*not 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.*all in its locals" 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--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--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--stopped
(if (plist-member bindings :stopped)
(plist-get bindings :stopped) "Missing"))
(flan-break-on-stop
(if (plist-member bindings :setting)
(plist-get bindings :setting) 'display))
(flan--busy (plist-get bindings :busy))
(executing-kbd-macro (plist-get bindings :macro))
(flan--connection 'stub))
(flan--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--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 "stopped at (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)))
;;; The macroexpansion buffer
;; The same kind of thing again: a reply in, a buffer out. What the live test
;; in test-flan.el cannot easily reach is the shape where *nothing*
;; expanded — a head that is not a macro, and a macro whose answer is its own
;; call — because both have to be arranged in a program. Here they are a
;; plist.
(message "\nthe macroexpansion buffer")
(let ((flan-macroexpand-request-function
(lambda (_) '(:status "ok" :text "(if (not false)\n (do 1 2))"
:flat "(if (not false) (do 1 2))"
:expanded t :macro "unless"))))
(with-temp-buffer
(flan-mode)
(insert "(unless false 1 2)")
(goto-char (point-min))
(flan-macroexpand))
(let ((text (with-current-buffer flan-macroexpansion-buffer (buffer-string))))
(test-flan--check "the expansion is drawn"
(string-match-p (regexp-quote "(if (not false)") text))
(test-flan--check "with the macro that produced it named"
(string-match-p "macro +unless" text))
(test-flan--check "and the form it came from"
(string-match-p (regexp-quote "(unless false 1 2)") text))
;; The one thing a reader of this buffer has to be told, because there is
;; nowhere else it could be said: nothing in it has a location of its own.
(test-flan--check "and what the locations in it mean"
(string-match-p "no locations of its own" text))
(test-flan--check "one step says so, rather than implying a fixpoint"
(string-match-p "one step" text))))
;; A head that is not a macro. The form comes back as itself, and the buffer
;; has to say which kind of nothing that is rather than looking like a very
;; short expansion.
(let ((flan-macroexpand-request-function
(lambda (_) '(:status "ok" :text "(+ 1 2)" :flat "(+ 1 2)"
:expanded nil
:note "the head of this form is not a macro"))))
(with-temp-buffer
(flan-mode)
(insert "(+ 1 2)")
(goto-char (point-min))
(flan-macroexpand))
(let ((text (with-current-buffer flan-macroexpansion-buffer (buffer-string))))
(test-flan--check "a head that is not a macro says so"
(string-match-p "not a macro" text))
(test-flan--check "and the macro line says none rather than being absent"
(string-match-p "macro +none" text))))
;; The refusals reach here as an ordinary error reply, and the command has to
;; signal rather than draw an empty buffer: a macro that never settles is the
;; one that gets here.
(let ((flan-macroexpand-request-function
(lambda (_) '(:status "error"
:message "expanding s/spin did not settle after 200 rounds"
:loc "buf.flan:3:3"))))
(with-temp-buffer
(flan-mode)
(insert "(s/spin)")
(goto-char (point-min))
(test-flan--check
"a refused expansion signals, carrying the daemon's words"
(let ((said (test-flan--caught #'flan-macroexpand)))
(and said (string-match-p "did not settle" said))))))
;; And the buffer refuses to be treated as source, which is the one way it
;; could do damage: the text in it is in no file and installing it would
;; redefine a name with code nobody wrote.
(with-current-buffer (get-buffer-create flan-macroexpansion-buffer)
(test-flan--check
"the expansion buffer refuses C-c C-c, C-c C-k and C-x C-e"
(seq-every-p
(lambda (k)
(eq (key-binding (kbd k)) #'flan-macroexpand--not-source))
'("C-c C-c" "C-c C-k" "C-x C-e"))))
;; A diagnostic's note is a second `file:line:col:' line, labelled `note:'.
;; `compile' reads it as an info message, and next-error has to stop on it as
;; well as on the error above it, in both buffers that carry diagnostics.
(message "\nnext-error reaches a note")
(let ((flan-diagnostics-buffer " *test-flan-diag*"))
(with-current-buffer (get-buffer-create flan-diagnostics-buffer)
(flan-diagnostics-mode)
(let ((inhibit-read-only t))
(insert "a.flan:3:5: cannot add a bool to an i64\n"
" ^\n"
"a.flan:1:7: note: the bool was bound here\n"
" -\n"
"b.flan:9:2: the next error\n"))
(goto-char (point-min))
(compilation-next-error 1)
(test-flan--check "from the error, n lands on its note"
(looking-at "a.flan:1:7: note:"))
(compilation-next-error 1)
(test-flan--check "and then on the next error"
(looking-at "b.flan:9:2:"))
(test-flan--check "the threshold is this buffer's, not the user's setting"
(and (local-variable-p 'compilation-skip-threshold)
(eql (default-value 'compilation-skip-threshold) 1))))
(kill-buffer flan-diagnostics-buffer))
;; `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)
;; The prompt's history, which needs no daemon either: what a key does at the
;; prompt and what survives in the history file are both settled by the ring
;; and by where point is. Evaluation is the half that needs a program, and
;; test_emacs drives that. Loaded here for the same reason as the two above.
(load (expand-file-name "test-flan-repl.el"
(file-name-directory load-file-name))
nil t)
;; The break buffer's keys under Evil, pressed through the command loop rather
;; than called. Evil's normal state binds 0 (beginning of line), 1-9 (a count)
;; and RET (next line) above any major mode's map, so without the buffer's map
;; taking precedence a digit moved point and took nothing. Run only where
;; Evil is installed: -Q loads no packages, so it is looked for in the two
;; places a package install puts it, and turned off again afterwards so nothing
;; above or below this runs under it.
(let* ((dirs (append (file-expand-wildcards "~/.config/emacs/elpa/evil-[0-9]*")
(file-expand-wildcards "~/.emacs.d/elpa/evil-[0-9]*")
(file-expand-wildcards "~/.config/emacs/elpa/goto-chg-*")
(file-expand-wildcards "~/.emacs.d/elpa/goto-chg-*")))
(load-path (append dirs load-path)))
(if (not (require 'evil nil t))
(message " skip the break buffer under Evil (Evil is not installed)")
(evil-mode 1)
(unwind-protect
(let* ((sent nil)
(flan-cnr-request-function
(lambda (form) (setq sent form) (list :status "ok")))
(buf (test-flan--cnr
(list :condition "Missing" :restarts '("retry" "skip")))))
(switch-to-buffer buf)
(evil-initialize-state)
(goto-char (point-min))
(execute-kbd-macro (kbd "0"))
(test-flan--check "under Evil, 0 takes restart 0"
(equal sent '(:op "restart-at" :index 0 :name "retry")))
(setq sent nil)
(switch-to-buffer buf)
(execute-kbd-macro (kbd "1"))
(test-flan--check "under Evil, 1 takes restart 1"
(equal sent '(:op "restart-at" :index 1 :name "skip")))
(setq sent nil)
(switch-to-buffer buf)
(goto-char (point-min))
(search-forward " 1: ")
(execute-kbd-macro (kbd "RET"))
(test-flan--check "under Evil, RET takes the restart on its line"
(equal sent '(:op "restart-at" :index 1 :name "skip")))
;; And the keys the buffer does not bind are still Evil's, not the
;; ones `special-mode-map' would bring with it.
(switch-to-buffer buf)
(dolist (k '(("h" . evil-backward-char) ("SPC" . evil-forward-char)
("<" . evil-shift-left)
("-" . evil-previous-line-first-non-blank)))
(test-flan--check (format "under Evil, %s is still Evil's" (car k))
(eq (key-binding (kbd (car k))) (cdr k))))
;; The other buffers of Flan's own: every key a mode's map binds
;; itself does what it does without Evil, and the keys it does not
;; bind stay Evil's.
(require 'flan-lower)
(require 'flan-watch)
(dolist (m '((flan-inspect-mode . flan-inspect-mode-map)
(flan-watch-mode . flan-watch-mode-map)
(flan-doc-mode . flan-doc-mode-map)
(flan-disassembly-mode . flan-disassembly-mode-map)
(flan-diagnostics-mode . flan-diagnostics-mode-map)
(flan-lower-mode . flan-lower-mode-map)))
(let ((b (get-buffer-create (format " *evil-%s*" (car m))))
(own nil))
(map-keymap-internal
(lambda (key def) (when (commandp def) (push (cons key def) own)))
(symbol-value (cdr m)))
(switch-to-buffer b)
(funcall (car m))
(evil-initialize-state)
(test-flan--check (format "%s binds keys of its own" (car m)) own)
(dolist (k own)
(test-flan--check
(format "under Evil, %s in %s is the mode's"
(key-description (vector (car k))) (car m))
(eq (key-binding (vector (car k))) (cdr k))))
(dolist (k '(("h" . evil-backward-char) ("SPC" . evil-forward-char)
("<" . evil-shift-left)
("-" . evil-previous-line-first-non-blank)))
(test-flan--check (format "under Evil, %s in %s is still Evil's"
(car k) (car m))
(eq (key-binding (kbd (car k))) (cdr k))))
(kill-buffer b))))
(evil-mode -1))))
(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
Reference in New Issue View Git Blame Copy Permalink