JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

A value you can walk into, because the walk has a bound

Browse Source 
C-x C-e renders once and stops at depth 4 and span 8. A field past either
comes back as "..." and nothing recovers it from the echo area. Re-rooting
the walk at that field renders it from depth 0, so the bound moves with you
— that, and not tidiness, is why an inspector is worth having beside the
expression evaluator.

CIDER keeps its inspector stack on the server because a JVM value can be
retained. Nothing here can: a Flan value has no header and the thunk that
rendered it is dlclosed the moment it returns. So the stack is a stack of
expressions on this side, and going into a field means sending a different
one — (.pos b) where the last one was b. It costs a re-evaluation per step,
which buys a view that is never stale and is why refresh is a key someone
presses rather than a timer.

Driven from fixtures, which is also the only way the cases a live program
will not hold still for get tested at all.
This commit is contained in:
Joseph Ferano 2026-09-12 04:08:13 +07:00
parent 71877a5baa
commit 94b78a1a83
4 changed files with 697 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

435
emacs/flan-inspect.el Normal file
View File

@ -0,0 +1,435 @@
;;; flan-inspect.el --- Navigate a running program's values -*- lexical-binding: t; -*-
;; `C-x C-e' renders a value once and puts it in the echo area. This is the
;; interactive version of the same walk: the fields laid out one per line, RET
;; to go into one, `l' to come back, `g' to read it again. CIDER's inspector,
;; adapted — and the adaptation is the whole design, so it is worth stating
;; what changed and why.
;;
;; CIDER's inspector keeps its stack **on the server**. `inspect-push' hands
;; the middleware an index and the middleware walks into the object it is
;; already holding; the client's own stack is only remembered point positions.
;; That is available to it because a JVM value can be retained: the middleware
;; keeps a reference and the collector leaves it alone.
;;
;; Nothing here can do that. A Flan value has no header, the thunk that
;; rendered it is `dlclose'd the moment it returns, and there is no heap to
;; retain anything in. So the stack is a stack of **expressions**, on this
;; side, and going into a field means sending a *different expression* —
;; `(.pos b)' where the last one was `b'. Two consequences, one good and one
;; that has to be said out loud:
;;
;; the view is never stale. Every step and every `g' reads the program as
;; it is now, at a frame boundary it agreed to stop on. CIDER's inspector
;; shows you the object as it was when you pushed;
;;
;; and the root expression runs again on every step. Appending a field
;; accessor to it is pure, but the root need not be — `(spawn-enemy)' as a
;; root spawns one per keystroke. Which is why there is no auto-refresh and
;; why `g' is a key someone presses.
;;
;; The other thing this buys, and the reason it is worth having at all next to
;; `C-x C-e': the renderer bounds its walk at depth 4 and span 8
;; (lib/session.ml). A field past either bound comes back as `...' and no
;; amount of squinting at the echo area recovers it. Re-rooting the walk at
;; that field renders it from depth 0 — the bound moves with you.
;;; Code:
(require 'seq)
(require 'subr-x)
(declare-function flan-dev--request "flan-dev" (form))
(defgroup flan-inspect nil
"Navigating values in a running Flan program."
:prefix "flan-inspect-"
:group 'flan)
(defcustom flan-inspect-buffer "*flan-inspect*"
"Where the inspector draws."
:type 'string)
(defvar flan-inspect-request-function #'flan-dev--request
"How the inspector reaches the program.
Called with one plist — a request — and returning the reply plist. It is a
variable rather than a direct call so that a test can hand the renderers a
reply without a daemon behind them, and so that this file names
`flan-dev.el' in exactly one place.")
;;; Reading what the renderer wrote
;; The value comes back as a string, and that string is very nearly an
;; s-expression — `(Blob {:id 7 :pos (V {:x 1.5 :y 0})})'. Nearly, because
;; Emacs' `read' has no `{', so it is parsed here instead. The grammar is
;; small and fixed by `Session.render' (lib/session.ml), and every case below
;; names the line of it that produces it.
;;
;; (Name {:f V :f V}) a struct, with ` ...' before the `}' if the walk hit
;; its span bound of 8 fields
;; [ V V V] an array or a slice, ` ...' likewise
;; (some V) / none an option
;; <ptr> a pointer, never followed
;; <Name> a named type the walk had no structure for
;; ... the depth bound, 4, reached at this position
;; :name an enum member, or its number if it matched none
;; "…" a string, escaped in C
;; true / false / () bool, and the value of a Unit expression
;; 1.5 / 7 / 18446… a number
;;
;; A node is a plist: :kind, :text (what the renderer wrote for it), :type
;; where there is one, and :children as a list of (LABEL . NODE).
(defun flan-inspect--skip-space (s i)
(while (and (< i (length s)) (memq (aref s i) '(?\s ?\n ?\t))) (setq i (1+ i)))
i)
(defun flan-inspect--read-string (s i)
"Read a quoted string starting at I (which is the opening quote)."
(let ((out (list ?\")) (i (1+ i)) (done nil))
(while (and (not done) (< i (length s)))
(let ((c (aref s i)))
(cond ((eq c ?\\)
(setq i (1+ i))
(when (< i (length s)) (push (aref s i) out) (setq i (1+ i))))
((eq c ?\") (push ?\" out) (setq i (1+ i)) (setq done t))
(t (push c out) (setq i (1+ i))))))
(cons (list :kind 'atom :text (concat (nreverse out))) i)))
(defun flan-inspect--read-atom (s i)
"Read a bare token at I: a number, a keyword, `true', `none', `...'."
(let ((start i))
(while (and (< i (length s))
(not (memq (aref s i) '(?\s ?\n ?\t ?\) ?\] ?\}))))
(setq i (1+ i)))
(let ((text (substring s start i)))
(cons (list :kind (if (equal text "...") 'trunc 'atom) :text text) i))))
(defun flan-inspect--read-angle (s i)
"Read `<ptr>' or `<Name>' at I."
(let ((end (or (string-match ">" s i) (1- (length s)))))
(let ((text (substring s i (1+ end))))
(cons (list :kind (if (equal text "<ptr>") 'ptr 'opaque) :text text)
(1+ end)))))
(defun flan-inspect--read-seq (s i)
"Read `[ V V]' at I, which is `[' — an array or a slice."
(let ((i (1+ i)) (kids nil) (n 0) (more nil) (done nil))
(while (not done)
(setq i (flan-inspect--skip-space s i))
(cond
((>= i (length s)) (setq done t))
((eq (aref s i) ?\]) (setq i (1+ i)) (setq done t))
(t (let ((r (flan-inspect--read s i)))
(setq i (cdr r))
;; A bare `...' inside a sequence is the renderer saying it stopped,
;; not an element. It is the last thing it writes either way.
(if (eq (plist-get (car r) :kind) 'trunc)
(setq more t)
(push (cons n (car r)) kids)
(setq n (1+ n)))))))
(cons (list :kind 'seq
:text (format "%d element%s%s" n (if (= n 1) "" "s")
(if more ", and more the renderer did not write" ""))
:truncated more
:children (nreverse kids))
i)))
(defun flan-inspect--read-struct (s i)
"Read `(Name {…})' or `(some V)' at I, which is `('."
(let ((j (1+ i)))
(let ((start j))
(while (and (< j (length s)) (not (memq (aref s j) '(?\s ?\))))) (setq j (1+ j)))
(let ((head (substring s start j)))
(cond
;; (some V). There is no accessor form in Flan that reaches an
;; option's payload — the compiler gets at it as field 1 and nothing
;; in the surface language does — so this parses, prints, and refuses
;; to be entered.
((equal head "some")
(let* ((r (flan-inspect--read s (flan-inspect--skip-space s j)))
(k (flan-inspect--skip-space s (cdr r))))
(cons (list :kind 'option :text "some" :type "Option"
:children (list (cons "some" (car r))))
(if (and (< k (length s)) (eq (aref s k) ?\))) (1+ k) k))))
(t
;; `(Name {' then `:field VALUE' pairs, then `})'.
(setq j (flan-inspect--skip-space s j))
(when (and (< j (length s)) (eq (aref s j) ?\{)) (setq j (1+ j)))
(let ((kids nil) (more nil) (done nil))
(while (not done)
(setq j (flan-inspect--skip-space s j))
(cond
((>= j (length s)) (setq done t))
((eq (aref s j) ?\}) (setq j (1+ j)) (setq done t))
((eq (aref s j) ?:)
(let ((start j))
(while (and (< j (length s)) (not (memq (aref s j) '(?\s ?\}))))
(setq j (1+ j)))
(let ((name (substring s (1+ start) j))
(r (flan-inspect--read s (flan-inspect--skip-space s j))))
(setq j (cdr r))
(push (cons name (car r)) kids))))
(t (let ((r (flan-inspect--read s j)))
(setq j (cdr r))
(if (eq (plist-get (car r) :kind) 'trunc)
(setq more t)
;; Not a `:field' and not `...'. Rather than guess, keep
;; it where it was written.
(push (cons "?" (car r)) kids))))))
(setq j (flan-inspect--skip-space s j))
(when (and (< j (length s)) (eq (aref s j) ?\))) (setq j (1+ j)))
(cons (list :kind 'struct :text head :type head
:truncated more
:children (nreverse kids))
j))))))))
(defun flan-inspect--read (s i)
"Read one rendered value out of S at I. Returns (NODE . NEXT-INDEX)."
(let ((i (flan-inspect--skip-space s i)))
(if (>= i (length s))
(cons (list :kind 'atom :text "") i)
(pcase (aref s i)
(?\( (flan-inspect--read-struct s i))
(?\[ (flan-inspect--read-seq s i))
(?\" (flan-inspect--read-string s i))
(?< (flan-inspect--read-angle s i))
(_ (flan-inspect--read-atom s i))))))
(defun flan-inspect-parse (rendered)
"Parse RENDERED — what the daemon put in a reply's :value — into a node."
(car (flan-inspect--read (or rendered "") 0)))
;;; Where a field is, said in Flan
;; A step is not an index into something remembered; it is a piece of source.
;; `(.pos b)' and `(at (.tags b) 2)' are expressions the program can be handed
;; exactly as a person would type them, which is what makes the whole thing
;; work without a handle to retain.
(defun flan-inspect-step-expr (expr step)
"The Flan expression reaching STEP inside EXPR."
(pcase step
(`(:field ,name) (format "(.%s %s)" name expr))
(`(:index ,i) (format "(at %s %d)" expr i))
(_ expr)))
;;; Why a thing cannot be entered
;; Every refusal is by name and carries its reason, because the alternative —
;; RET doing nothing on some lines and something on others — is a UI that
;; teaches you nothing about the language.
(defun flan-inspect-refusal (node)
"Why NODE cannot be inspected, or nil if it can."
(pcase (plist-get node :kind)
('struct (and (null (plist-get node :children))
"a struct with no fields the renderer could reach"))
('seq (and (null (plist-get node :children))
"an empty sequence: there is no element to go into"))
('option
"an option's payload: Flan has no accessor form that reaches it, so there is no expression to send")
('ptr
"a pointer: the renderer never follows one, and dereferencing a pointer on your behalf is not safe")
('trunc
"truncated: the walk stopped at its depth bound of 4. Inspect the field that holds it, which re-roots the walk")
('opaque
(format "%s: the walk had no structure for this type, so there are no fields to show"
(plist-get node :text)))
('atom (format "%s is an atom; it has no fields" (plist-get node :text)))
(_ "not something this inspector knows how to enter")))
;;; Drawing it
(defvar-local flan-inspect--stack nil
"Where we have been: a list of (EXPR . POINT), innermost last-pushed first.")
(defvar-local flan-inspect--expr nil "The expression this buffer is showing.")
(defvar-local flan-inspect--node nil "Its parsed value.")
(defun flan-inspect--label (child)
(let ((k (car child)))
(if (integerp k) (format "%d." k) (format ":%s" k))))
(defun flan-inspect--summary (node)
"One line for NODE, as it appears beside its label."
(pcase (plist-get node :kind)
('struct (format "(%s …%s)" (plist-get node :type)
(let ((n (length (plist-get node :children))))
(format " %d field%s" n (if (= n 1) "" "s")))))
('seq (plist-get node :text))
('option (format "(some …)"))
(_ (plist-get node :text))))
(defun flan-inspect--render (expr node stack)
"Draw NODE, reached by EXPR, with STACK behind it."
(let ((inhibit-read-only t))
(erase-buffer)
(insert (propertize expr 'face 'font-lock-function-name-face) "\n")
(insert (propertize
(pcase (plist-get node :kind)
('struct (format "a %s\n" (plist-get node :type)))
('seq (format "%s\n" (plist-get node :text)))
('option "an option\n")
('ptr "a pointer — never followed\n")
(_ (format "%s\n" (plist-get node :text))))
'face 'font-lock-type-face))
;; The stack made visible. CIDER keeps it and does not show it; here it is
;; the difference between a value and *which* value, and the thing that was
;; typed at the root is often several steps back by now.
(when stack
(insert (propertize
(concat " via "
(string-join (reverse (mapcar #'car stack)) " > ")
" > here\n")
'face 'shadow)))
(insert "\n")
(let ((kids (plist-get node :children)))
(cond
(kids
(insert (propertize (if (eq (plist-get node :kind) 'seq)
"--- Elements:\n" "--- Fields:\n")
'face 'font-lock-comment-face))
(let ((w (apply #'max 4 (mapcar (lambda (c) (length (flan-inspect--label c))) kids))))
(dolist (c kids)
(let* ((label (flan-inspect--label c))
(child (cdr c))
(step (if (integerp (car c)) (list :index (car c))
(list :field (car c))))
(start (point)))
(insert (format " %s%s " label
(make-string (- w (length label)) ?\s)))
(insert (flan-inspect--summary child) "\n")
(add-text-properties
start (point)
(list 'flan-inspect-step step
'flan-inspect-node child
'mouse-face 'highlight)))))
(when (plist-get node :truncated)
(insert (propertize
" ... the renderer stopped at its span bound of 8; the rest was not written\n"
'face 'font-lock-warning-face))))
(t
(insert (propertize
(format "Nothing to go into: %s\n" (flan-inspect-refusal node))
'face 'font-lock-comment-face)))))
(insert "\n")
(insert (propertize
"RET inspect l back g refresh TAB/n next p previous q quit\n"
'face 'shadow))
(goto-char (point-min))))
;;; The commands
(defun flan-inspect--value (expr)
"Ask the program for EXPR's value, rendered. Signals if it refuses."
(let ((r (funcall flan-inspect-request-function
(list :op "eval-expr" :code expr :file "<inspect>"))))
(unless (equal (plist-get r :status) "ok")
(user-error "flan: %s" (or (plist-get r :message) "refused")))
(or (plist-get r :value)
(user-error "flan: the program answered without a value for %s" expr))))
(defun flan-inspect--show (expr &optional stack)
"Render EXPR in the inspector buffer, with STACK behind it."
(let ((value (flan-inspect--value expr))
(buf (get-buffer-create flan-inspect-buffer)))
(with-current-buffer buf
(unless (derived-mode-p 'flan-inspect-mode) (flan-inspect-mode))
(setq flan-inspect--expr expr)
(setq flan-inspect--node (flan-inspect-parse value))
(setq flan-inspect--stack stack)
(flan-inspect--render expr flan-inspect--node stack))
(display-buffer buf)
buf))
;;;###autoload
(defun flan-inspect (expr)
"Inspect the value of EXPR in the running program.
Interactively, the expression before point, or one you type."
(interactive
(list (read-string "Inspect: "
(ignore-errors
(buffer-substring-no-properties
(save-excursion (backward-sexp) (point)) (point))))))
(flan-inspect--show expr nil))
(defun flan-inspect-into ()
"Go into the field or element at point."
(interactive)
(let ((step (get-text-property (point) 'flan-inspect-step))
(node (get-text-property (point) 'flan-inspect-node)))
(unless step (user-error "flan: nothing to inspect on this line"))
(let ((why (flan-inspect-refusal node)))
(when why (user-error "flan: %s" why)))
(let ((expr (flan-inspect-step-expr flan-inspect--expr step))
(stack (cons (cons flan-inspect--expr (point)) flan-inspect--stack)))
(flan-inspect--show expr stack))))
(defun flan-inspect-pop ()
"Back to the value you came from, at the line you left."
(interactive)
(unless flan-inspect--stack
(user-error "flan: this is the root; there is nothing behind it"))
(let* ((top (car flan-inspect--stack))
(rest (cdr flan-inspect--stack)))
(flan-inspect--show (car top) rest)
(with-current-buffer flan-inspect-buffer
(goto-char (min (cdr top) (point-max))))))
(defun flan-inspect-refresh ()
"Read the same expression again.
Deliberately a key rather than a timer: the expression runs in the program,
and a root with an effect in it would fire once a second forever."
(interactive)
(unless flan-inspect--expr (user-error "flan: nothing is being inspected"))
(let ((p (point)))
(flan-inspect--show flan-inspect--expr flan-inspect--stack)
(with-current-buffer flan-inspect-buffer (goto-char (min p (point-max))))))
(defun flan-inspect-next (&optional n)
"Move to the next inspectable line. With N, that many."
(interactive "p")
(dotimes (_ (or n 1))
(let ((p (next-single-property-change (point) 'flan-inspect-step)))
(while (and p (null (get-text-property p 'flan-inspect-step)))
(setq p (next-single-property-change p 'flan-inspect-step)))
(if p (goto-char p)
;; Wrap, as CIDER's does: a list you have walked off the end of should
;; come back round rather than stop dead.
(goto-char (point-min))
(let ((q (next-single-property-change (point) 'flan-inspect-step)))
(when q (goto-char q)))))))
(defun flan-inspect-previous (&optional n)
"Move to the previous inspectable line. With N, that many."
(interactive "p")
(dotimes (_ (or n 1))
(let ((p (previous-single-property-change (point) 'flan-inspect-step)))
(while (and p (null (get-text-property p 'flan-inspect-step)))
(setq p (previous-single-property-change p 'flan-inspect-step)))
(when p (goto-char (or (previous-single-property-change (1+ p) 'flan-inspect-step)
p))))))
(defvar flan-inspect-mode-map
(let ((map (make-sparse-keymap)))
;; CIDER's, and the same letters mean the same things: someone who has used
;; one should not have to learn the other.
(define-key map (kbd "RET") #'flan-inspect-into)
(define-key map [mouse-1] #'flan-inspect-into)
(define-key map "l" #'flan-inspect-pop)
(define-key map "g" #'flan-inspect-refresh)
(define-key map (kbd "TAB") #'flan-inspect-next)
(define-key map "n" #'flan-inspect-next)
(define-key map [backtab] #'flan-inspect-previous)
(define-key map "p" #'flan-inspect-previous)
(define-key map "q" #'quit-window)
map)
"Keys in `flan-inspect-mode'.")
(define-derived-mode flan-inspect-mode special-mode "flan-inspect"
"Look at a value in the running Flan program."
(setq buffer-read-only t)
(setq-local truncate-lines t))
(provide 'flan-inspect)
;;; flan-inspect.el ends here

234
emacs/test-flan-cider.el Normal file
View File

@ -0,0 +1,234 @@
;;; 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)
(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})"))))
;;; The inspector buffer
(message "\nthe inspector buffer")
(defun test-flan--inspect (expr rendered)
"Draw EXPR's RENDERED value in a temp buffer and return it, live."
(let ((flan-inspect-request-function
(lambda (_) (list :status "ok" :value rendered)))
(flan-inspect-buffer " *test-inspect*"))
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
(save-window-excursion (flan-inspect--show expr nil))))
(let* ((buf (test-flan--inspect
"b" "(Blob {:id 7 :name \"sandy\" :pos (V {:x 1.5 :y 0})})"))
(text (with-current-buffer buf (buffer-string))))
(test-flan--check "the expression is at the top" (string-match-p "\\`b\n" text))
(test-flan--check "and the type under it" (string-match-p "a Blob" text))
(test-flan--check "the fields are listed" (string-match-p ":id.*7" text))
(test-flan--check "a nested struct is summarised, not expanded"
(string-match-p ":pos +(V … 2 fields)" text))
(test-flan--check "and the keys are shown" (string-match-p "RET inspect" text))
;; Every field line carries the step that reaches it.
(with-current-buffer buf
(goto-char (point-min))
(flan-inspect-next)
(test-flan--check "TAB lands on the first field"
(equal (get-text-property (point) 'flan-inspect-step)
'(:field "id")))
(flan-inspect-next)
(flan-inspect-next)
(test-flan--check "and walks to the third"
(equal (get-text-property (point) 'flan-inspect-step)
'(:field "pos")))))
;; Going in sends a *different expression*, which is the entire adaptation.
(let ((asked nil))
(let ((flan-inspect-request-function
(lambda (form)
(push (plist-get form :code) asked)
(list :status "ok"
:value (if (equal (plist-get form :code) "(.pos b)")
"(V {:x 1.5 :y 0})"
"(Blob {:id 7 :pos (V {:x 1.5 :y 0})})"))))
(flan-inspect-buffer " *test-inspect*"))
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
(save-window-excursion
(flan-inspect--show "b" nil)
(with-current-buffer " *test-inspect*"
(goto-char (point-min))
(flan-inspect-next) (flan-inspect-next) ; :pos
(flan-inspect-into)
(test-flan--check "going in asks for the accessor expression"
(equal (car asked) "(.pos b)"))
(test-flan--check "and the buffer is now showing that"
(string-match-p "\\`(\\.pos b)\n" (buffer-string)))
(test-flan--check "with the stack behind it"
(string-match-p "via b > here" (buffer-string)))
(flan-inspect-pop)
(test-flan--check "coming back asks for the one we came from"
(equal (car asked) "b"))
(test-flan--check "and there is no stack left"
(not (string-match-p "via" (buffer-string))))
(test-flan--check "popping at the root refuses"
(string-match-p
"nothing behind it"
(or (test-flan--caught #'flan-inspect-pop) "")))))))
;; RET on something that cannot be entered refuses there, rather than sending
;; an expression the program would reject.
(let* ((buf (test-flan--inspect "p" "(Node {:next <ptr> :n 1})")))
(with-current-buffer buf
(goto-char (point-min))
(flan-inspect-next)
(test-flan--check "RET on a pointer field refuses, naming it"
(string-match-p "pointer"
(or (test-flan--caught #'flan-inspect-into) "")))))
;; An atom root has nothing to go into, and the buffer says so rather than
;; drawing an empty field list.
(let ((text (with-current-buffer (test-flan--inspect "(.x p)" "1.5") (buffer-string))))
(test-flan--check "an atom root explains itself"
(string-match-p "Nothing to go into:.*atom" text)))
;; The span bound is drawn, because a field list that silently stops is a lie
;; about the value.
(let ((text (with-current-buffer
(test-flan--inspect "w" "(Wide {:a 1 :b 2 ...})") (buffer-string))))
(test-flan--check "span truncation is drawn, not dropped"
(string-match-p "span bound of 8" text)))
(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

2
test/dune
View File

@ -1,5 +1,5 @@
(tests
(names test_flan test_acceptance test_reload test_agent test_session test_dev test_emacs test_repl)
(names test_flan test_acceptance test_reload test_agent test_session test_dev test_emacs test_repl test_cider)
(libraries flan unix)
; The acceptance programs are part of the test corpus: if the reader, the
; parser or the checker regresses on them we want to know here, not at the CLI.

27
test/test_cider.ml Normal file
View File

@ -0,0 +1,27 @@
(* The inspector and the break buffer, driven from fixtures.
Unlike test_emacs.ml there is no daemon and no running program behind this,
and that is the point rather than a shortcut. Both buffers are functions
from a reply's data to text with properties on it, and every interesting way
they can be wrong is on that side: a struct the reader mis-parses, a
shadowed restart drawn as though it could be taken, a section quietly
omitted where it should have been refused. Fixtures also reach the states a
live program is hard to hold still in — a value past the renderer's depth
bound, two restarts sharing a name, a frame with locals in it at all.
Skipped, not failed, where there is no emacs: the compiler does not depend
on one. *)
let () =
if Sys.command "command -v emacs > /dev/null 2>&1" <> 0 then
print_endline "cider: skipped (no emacs on PATH)"
else
let code =
Sys.command
"emacs -Q --batch -L ../../../emacs -l ../../../emacs/test-flan-cider.el 2>&1"
in
if code = 0 then print_endline "cider: all tests passed"
else begin
Printf.printf "\nthe inspector/break buffer tests exited %d\n" code;
exit 1
end