JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/emacs/flan-inspect.el
Joseph Ferano a0610cecd5 A number in the inspector reads in the two bases it was written in 
Decimal is what the value is and stays first; hex and binary go beside it. It
is the wrong base for about half the numbers anyone opens this buffer for — a
colour is 0x303030FF, a gesture is an OR of flags, a mask is read a bit at a
time — and reading those out of a decimal is arithmetic done by hand.

In two places: under the header of a value opened on its own, and on each
numeric row of a field list. The second is the one that matters, because a leaf
cannot be stepped into, so the field list is the only place most numbers are
ever seen.

Nothing is asked of the program. It is arithmetic on text the renderer already
wrote, so it works on a stopped program and costs no round trip. Binary is
grouped in nibbles because a mask is read in nibbles. A negative is shown as
the 64-bit two's complement it is in memory and says the width out loud: the
rendered value carries none, and every Flan integer comes back through i64.

A float is left alone rather than answered wrongly — its bits are an IEEE
layout, reinterpreting them is a different question, and the rendered text does
not carry the width to answer it.

The pointer half of this is not done and the refusal now says why. Render.render
writes the bare word <ptr> for every pointer on purpose: it is the same renderer
print uses, an address is not stable across runs, and test_acceptance pins the
current text for that reason. Showing one is a decision about the language's
printer, not about this buffer.
2026-09-12 16:19:39 +07:00

524 lines
23 KiB
EmacsLisp
Raw Blame History

;;; 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
;; And its address is not here either. `Render.render' (lib/render.ml)
;; writes the bare word `<ptr>' for every pointer, on purpose: it is the
;; same renderer `print' uses, an address is not stable across runs, and
;; test_acceptance.ml pins the current text for exactly that reason.
;; Showing the address needs the renderer to write it, which is a decision
;; about the language's printer rather than about this buffer.
"a pointer: the renderer never follows one, and dereferencing a pointer on your behalf is not safe. It does not write the address either — `print' uses the same renderer, and an address is not stable across runs")
('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))))
;;; What a leaf is, beyond its decimal
;; A number is shown in decimal and nothing else, which is the wrong base for
;; about half the numbers anyone opens this buffer for: a colour is
;; `0x303030FF', a gesture is an OR of flags, a mask is read a bit at a time.
;; The decimal is still first — it is what the value *is* — and the other two
;; bases are beside it.
;;
;; Nothing is asked of the program for this. It is arithmetic on a number the
;; renderer already wrote, which is why it works on a stopped program and costs
;; no round trip.
(defun flan-inspect--integer (node)
"NODE's value as an integer, or nil if it is not written as one.
Only a bare decimal integer counts. A float is not one: its bits are an IEEE
layout and reinterpreting them would be a different question from this, and one
the rendered text does not carry the width to answer."
(let ((text (plist-get node :text)))
(and (eq (plist-get node :kind) 'atom)
(stringp text)
(string-match-p "\\`-?[0-9]+\\'" text)
(string-to-number text))))
(defun flan-inspect--binary (n)
"N in base two, grouped in fours."
(let ((bits "") (n n))
(if (zerop n)
"0"
(while (> n 0)
(setq bits (concat (number-to-string (logand n 1)) bits)
n (ash n -1)))
;; Nibbles, because a mask is read in nibbles. Pad to a multiple of four
;; so the groups line up with the hex beside them.
(let ((pad (% (- 4 (% (length bits) 4)) 4)))
(setq bits (concat (make-string pad ?0) bits)))
(let ((out nil) (i 0))
(while (< i (length bits))
(push (substring bits i (min (+ i 4) (length bits))) out)
(setq i (+ i 4)))
(string-join (nreverse out) "_")))))
(defun flan-inspect--detail (node)
"The other bases NODE reads in, as a string, or nil.
A negative number is shown as the 64-bit two's complement it is in memory, and
says so: the rendered value carries no width, so 64 is the only one that can be
stated honestly — every Flan integer is rendered through i64."
(let ((n (flan-inspect--integer node)))
(when n
(if (>= n 0)
(format "0x%X 0b%s" n (flan-inspect--binary n))
(let ((two (logand n #xFFFFFFFFFFFFFFFF)))
(format "0x%X 0b%s (two's complement, 64-bit)"
two (flan-inspect--binary two)))))))
(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 other bases, under the value rather than beside it: this is the line
;; someone opened the inspector on a number *for*, and it is long.
(let ((detail (flan-inspect--detail node)))
(when detail (insert (propertize (concat detail "\n") 'face 'shadow))))
;; 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))
;; A numeric field carries its other bases here, where the field
;; list is read, rather than only when it is opened on its own —
;; and a leaf cannot be opened on its own at all.
(let ((detail (flan-inspect--detail child)))
(when detail
(insert (propertize (concat " " detail) 'face 'shadow))))
(insert "\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--fields ()
"The start of every inspectable line, in order.
Both movement commands go through this rather than walking property changes
by hand: a field line has the property on all of it, so `next-single-...'
from the middle of one finds the *end* of the line you are already on, and
forward and backward then disagree about where a field begins."
(let ((out nil) (p (point-min)))
(while (< p (point-max))
;; A new field begins where the property's *value* changes, not where the
;; property appears: field lines are contiguous, so the last character of
;; one carries a step just as the first character of the next does.
(when (and (get-text-property p 'flan-inspect-step)
(or (= p (point-min))
(not (equal (get-text-property p 'flan-inspect-step)
(get-text-property (1- p) 'flan-inspect-step)))))
(push p out))
(setq p (1+ p)))
(nreverse out)))
(defun flan-inspect-next (&optional n)
"Move to the next inspectable line. With N, that many.
Wraps, as CIDER's does: a list you have walked off the end of should come
back round rather than stop dead."
(interactive "p")
(let ((fields (flan-inspect--fields)))
(unless fields (user-error "flan: there is nothing to move between"))
(dotimes (_ (or n 1))
(goto-char (or (seq-find (lambda (p) (> p (point))) fields)
(car fields))))))
(defun flan-inspect-previous (&optional n)
"Move to the previous inspectable line. With N, that many.
Wraps too — the same list, walked the other way, and an asymmetry here is
the kind of thing nobody reports and everybody notices."
(interactive "p")
(let ((fields (flan-inspect--fields)))
(unless fields (user-error "flan: there is nothing to move between"))
(dotimes (_ (or n 1))
(goto-char (or (seq-find (lambda (p) (< p (point))) (reverse fields))
(car (last fields)))))))
(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
Reference in New Issue View Git Blame Copy Permalink