Joseph Ferano
3dd9f61b7d
C-c C-m. One step on the bare key, the fixpoint under C-u: a macro may quasiquote a call to another macro, and Loc.from_macro is outermost-wins, so by the time a full expansion settles the intermediate name is gone. One step is the only thing that can say which macro produced what. The expansion runs against the macros the *session* holds -- the prelude's, its imports', and every defmacro evaluated since it started -- and writes nothing back: a defmacro handed to C-c C-m does not join the session by having been looked at. Both non-termination refusals stay refusals, and only where they are needed. One step makes one call and does not look at the answer, so (s/spin) one- stepped answers with itself; all the way hits the fuel and names the macro, inside Dev.serve's guard, so the daemon replies rather than hanging. Macro's module handling is a Fun.protect now -- a build that raised was a process about to exit, and the daemon is not that process. No printer for a Form existed. Form.to_string is an error-message renderer and is what Macro.key digests, so it is untouched; Form.to_source round-trips floats, strings and bytes through the reader, and Form.pretty decides where the line breaks go and leaves the columns to flan-mode. The answer is a read-only flan-mode buffer shaped like the disassembly one, with cnr's idea in it: m expands the form at point one more step in place. Three inherited keys refuse by name -- an expansion is in no file. The text is sent padded onto its own line and its own column, unlike C-x C-e, so the refusal lands on the call and not at the start of its line.
1216 lines
60 KiB
EmacsLisp
1216 lines
60 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 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-dev--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-dev--request) flan-dev--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-dev--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-dev--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 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)))
|
|
|
|
|
|
;;; The macroexpansion buffer
|
|
|
|
;; The same kind of thing again: a reply in, a buffer out. What the live test
|
|
;; in test-flan-dev.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"))))
|
|
|
|
;; `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
|