1276 lines
63 KiB
EmacsLisp
1276 lines
63 KiB
EmacsLisp
;;; flan-inspect.el --- Navigate a running program's values -*- lexical-binding: t; -*-
|
|
|
|
;; Author: Joseph Ferano <joseph@ferano.io>
|
|
;; Version: 0.1.0
|
|
;; Package-Requires: ((emacs "29.1"))
|
|
;; Keywords: languages, lisp, tools
|
|
|
|
;; The headers above are what make this directory installable. M-x
|
|
;; package-install-file on it reads them, and a file with no Version: is not a
|
|
;; package as far as package.el is concerned -- until now the client was
|
|
;; reachable only by adding it to load-path by hand, which is a thing to
|
|
;; explain to every person who wants to try it.
|
|
;;
|
|
;; 29.1 is the floor because it is the oldest Emacs any of this has been run
|
|
;; against, not because some function here is known to need it. dape, which
|
|
;; flan-dape drives, asks for 29.1 as well and is a soft dependency: it is
|
|
;; reached through declare-function, so the rest of the client loads and works
|
|
;; without it and it is deliberately not listed above. The compiler this talks
|
|
;; to is not an Emacs package and cannot be listed here either -- emacs/MANUAL.md
|
|
;; says what has to be on PATH.
|
|
|
|
;; `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.
|
|
;;
|
|
;;; Two ways to root a walk, and why there had to be a second
|
|
;;
|
|
;; Everything above describes the *expression* root, and it has one hole: an
|
|
;; expression is evaluated where the evaluator stands. `i' on a local in the
|
|
;; break buffer used to send that local's name, and on the innermost frame
|
|
;; that lands in the right frame by luck. On any other it may resolve to a
|
|
;; global, to another binding of the same name, or to nothing — with the
|
|
;; locals listing right above it showing the frame's own storage, because that
|
|
;; listing renders from each frame's slot addresses and is frame-accurate.
|
|
;; The display was right and this buffer was not.
|
|
;;
|
|
;; Rooting at the slot's address alone does not fix it, and that was tried:
|
|
;; an address is not an expression, so the first RET has nothing to build
|
|
;; from. What the shadow stack changed is that the *step* does not have to be
|
|
;; an expression either. The daemon has the frame's address and every slot's
|
|
;; type, so going into a field is an address plus an offset with that field's
|
|
;; type — the arithmetic `Render.render' already does for the listing. So
|
|
;; there is a second rooting mode here, `flan-inspect-slot', and the daemon
|
|
;; verb behind it is `(:op "inspect" :frame N :slot I :path (...))'.
|
|
;;
|
|
;; The two roots are not equally capable and the buffer says which it is on:
|
|
;;
|
|
;; the expression root works on a *running* program and roots at anything
|
|
;; you can write, a call included. It cannot reach an option's payload,
|
|
;; because Flan has no accessor form that does, and it cannot say which
|
|
;; frame it means;
|
|
;;
|
|
;; the slot root names one frame and one slot, so it is exact, and it
|
|
;; reaches an option's payload and a data type case's fields, which have offsets
|
|
;; but no accessor. It needs a stopped program, it is refused if the
|
|
;; frame's body was redefined since it was entered — the same slot
|
|
;; fingerprint the listing is refused by — and it cannot root at an
|
|
;; expression, so `g' after the program resumes is refused rather than
|
|
;; quietly answered from somewhere else.
|
|
;;
|
|
;; `l' never crosses between them, and that is structural rather than a rule:
|
|
;; a stack entry carries its own root, RET only ever extends the path under
|
|
;; the root it already has, and every new root — `flan-inspect',
|
|
;; `flan-inspect-slot' — starts with an empty stack. So a mixed stack cannot
|
|
;; be built, and that stays true if a third rooting mode is ever added.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'seq)
|
|
(require 'subr-x)
|
|
|
|
(declare-function flan--request "flan" (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--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.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))
|
|
;; A dot, which is how a struct literal is written in the
|
|
;; source and now how `Render.render' prints one. The colon
|
|
;; belongs to keywords — an enum member renders as `:green', and
|
|
;; one of those is a *value* here, never a field label — so the
|
|
;; two cannot be told apart by anything but this character.
|
|
;; `...' also begins with a dot and is the renderer saying it
|
|
;; stopped, not a field called `..'. A field name never starts
|
|
;; with a second dot, so one character of lookahead separates
|
|
;; them.
|
|
((and (eq (aref s j) ?.)
|
|
(< (1+ j) (length s))
|
|
(not (eq (aref s (1+ 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.
|
|
A `:field' step may carry the type it was read out of, for the slot root's
|
|
benefit; here it is ignored, because an accessor is written the same way
|
|
whatever the value came from."
|
|
(pcase step
|
|
(`(:field ,name . ,_) (format "(.%s %s)" name expr))
|
|
(`(:index ,i) (format "(at %s %d)" expr i))
|
|
(_ expr)))
|
|
|
|
;;; Where a field is, said as an offset
|
|
|
|
;; The slot root's version of the same step, and it is not source: the daemon
|
|
;; is walking a type, so a field is its name and an element is its number.
|
|
;; Two cases need more than the name.
|
|
;;
|
|
;; A data type's payload sits at an offset that depends on which case the value
|
|
;; is in, and only the renderer knows which case it currently is — it wrote
|
|
;; `(Union.case {.f …})'. So the type travels with the step and the wire
|
|
;; spelling is `Union.case.f'. Guessing the case from a field name two
|
|
;; cases share would read one case's layout over another's payload.
|
|
;;
|
|
;; An option's payload has no name at all; it is the symbol `some'.
|
|
|
|
(defun flan-inspect-wire-step (step)
|
|
"STEP as the `inspect' op spells it."
|
|
(pcase step
|
|
(`(:field ,name ,type)
|
|
(if (and (stringp type) (string-match-p "\\." type))
|
|
(concat type "." name)
|
|
name))
|
|
(`(:field ,name) name)
|
|
(`(:index ,i) i)
|
|
(`(:some) 'some)
|
|
(_ (format "%s" step))))
|
|
|
|
;;; A root, and the path walked from it
|
|
|
|
;; A root is `(:expr EXPR)', `(:slot FRAME SLOT NAME)' or `(:addr N TYPE)'.
|
|
;; The path is a list of steps applied to it in order, and the pair is the
|
|
;; whole of this buffer's position — which is why a stack entry carries both
|
|
;; and `l' cannot cross between two kinds of root by accident.
|
|
;;
|
|
;; The third one has no frame in it. An expression root is evaluated wherever
|
|
;; the evaluator stands and a slot root is a frame and an index; an address
|
|
;; root is a number somebody has in their hand, out of a debugger or a
|
|
;; valgrind report, and the daemon asks the allocation registry what is there.
|
|
;; It takes no path: what it renders is a `(Ptr T)', so the whole answer is
|
|
;; the pointer arm's branch — followed if the storage is live, an epitaph if
|
|
;; it is not — and stepping in would be stepping from the pointee, which is
|
|
;; the deref the registry has only just been asked to bless.
|
|
|
|
(defun flan-inspect--root-label (root path)
|
|
"How ROOT walked by PATH is named at the top of the buffer and in the trail."
|
|
(pcase root
|
|
(`(:expr ,expr)
|
|
(seq-reduce #'flan-inspect-step-expr path expr))
|
|
(`(:slot ,frame ,_slot ,name)
|
|
(concat (format "%s [frame %d]" name frame)
|
|
(mapconcat (lambda (s)
|
|
(pcase s
|
|
(`(:field ,f . ,_) (concat "." f))
|
|
(`(:index ,i) (format "[%d]" i))
|
|
(`(:some) ".some")
|
|
(_ "")))
|
|
path "")))
|
|
;; The address in hex, because that is the spelling every tool that hands
|
|
;; one out uses, and the type only when it was *named*: an unnamed one is
|
|
;; the registry's own answer and the reply's own `:type' line says it.
|
|
(`(:addr ,addr ,ty)
|
|
(if ty (format "#x%x as %s" addr ty) (format "#x%x" addr)))
|
|
(_ "?")))
|
|
|
|
;;; 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 &optional root)
|
|
"Why NODE cannot be inspected, or nil if it can.
|
|
ROOT is the root the walk is on, because two of these are refusals of the
|
|
*expression* root rather than of the value. Omitted means the expression
|
|
root, which is the older and the more limited of the two."
|
|
(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
|
|
;; The one place the two roots differ in the slot root's favour, and it
|
|
;; is worth saying which it is rather than refusing flatly: the payload
|
|
;; is field 1 and the compiler reaches it there, so an address root steps
|
|
;; into it by offset. Nothing in the surface language does, so an
|
|
;; expression root has nothing to send.
|
|
(and (not (eq (car-safe root) :slot))
|
|
"an option's payload: Flan has no accessor form that reaches it, so there is no expression to send. `i' on a local in the break buffer roots at the slot's address instead, and that root can step into it"))
|
|
('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
|
|
;; A *followed* pointer lands here rather than on the `ptr' arm above,
|
|
;; because that arm matches the bare word. Saying "no structure for this
|
|
;; type" of it would be false and unhelpful at once: it has structure, it
|
|
;; is right there, and the reason you cannot step in is that the step
|
|
;; would start from the pointee — the deref the registry blessed once and
|
|
;; is not being asked about again.
|
|
(if (string-prefix-p "<ptr " (or (plist-get node :text) ""))
|
|
"a pointer the registry let the renderer follow: the pointee is already drawn, one level deeper. Stepping in would step from it, which is a second deref nobody has asked about — root at it with `M-x flan-inspect-address' instead"
|
|
(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--root nil
|
|
"What this buffer's walk starts from.
|
|
One of `(:expr EXPR)\=', `(:slot FRAME SLOT NAME)\=' or `(:addr N TYPE)\='.")
|
|
(defvar-local flan-inspect--path nil
|
|
"The steps walked from `flan-inspect--root\=', outermost first.
|
|
Together with the root this is the whole of where the buffer is. It is a
|
|
path rather than a remembered value because nothing here can retain a Flan
|
|
value: every step is a fresh request, which is what keeps the view current.")
|
|
(defvar-local flan-inspect--stack nil
|
|
"Where we have been: a list of (ROOT PATH . POINT), last-pushed first.
|
|
Each entry carries its own root, which is what makes `l\=' unable to cross
|
|
between two kinds of root: it can only ever restore a pair that was pushed
|
|
whole.")
|
|
(defvar-local flan-inspect--node nil "The parsed value being shown.")
|
|
(defvar-local flan-inspect--type nil
|
|
"The type the daemon said the walk ended at, or nil if it did not say.
|
|
Only the slot root answers with one — it is walking a type, so it knows. An
|
|
expression root gets back a rendering and nothing else, and the rendering of
|
|
an atom does not carry its type.")
|
|
(defvar-local flan-inspect--rendered nil
|
|
"What the program wrote, before it was parsed.
|
|
Kept because it is the thing edit mode hands you: a Flan literal is what the
|
|
renderer writes, so the buffer you type into is the value's own spelling and
|
|
not a second notation invented for editing it.")
|
|
(defvar-local flan-inspect--at-stop nil
|
|
"Which stop this buffer was drawn at, as the daemon numbered it.
|
|
Nil where the reply did not say — only the slot root does, because only it
|
|
reads from a frame, and only what is read from a frame can be written back.
|
|
A write carries this number, and the program refuses it if it has been round
|
|
its loop and stopped again since: what is on the screen would then describe
|
|
storage that has moved, and overwriting it would be aimed at nothing anybody
|
|
looked at.")
|
|
(defvar-local flan-inspect--editing nil
|
|
"Where the value starts, while this buffer is the value rather than a listing.
|
|
A marker and not a flag, because the header above it is two lines or three
|
|
depending on whether the daemon named a type, and the reader that parses the
|
|
buffer back has to start in the same place this one stopped writing.")
|
|
|
|
(defun flan-inspect--label (child)
|
|
"How CHILD is named in the list: `0.' for an element, `.x' for a field.
|
|
A field is written with the dot it is written with in the source, which is also
|
|
what `flan-inspect-step-expr' puts in the expression it sends."
|
|
(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 (root path node stack &optional declared)
|
|
"Draw NODE, reached by ROOT walked by PATH, with STACK behind it.
|
|
DECLARED is the type the daemon named, when it named one."
|
|
(let ((inhibit-read-only t))
|
|
(erase-buffer)
|
|
(insert (propertize (flan-inspect--root-label root path)
|
|
'face 'font-lock-function-name-face)
|
|
"\n")
|
|
;; The declared type wins over the one read back out of the rendering,
|
|
;; because it is the better fact and only one root can supply it: the slot
|
|
;; root is walking `Tast.fn.slots\=' and knows `i64\=' where the rendering says
|
|
;; only `7\='. An expression root has nothing but the rendering.
|
|
(insert (propertize
|
|
(if declared
|
|
(format "%s\n" declared)
|
|
(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 (lambda (e)
|
|
(flan-inspect--root-label
|
|
(car e) (cadr e)))
|
|
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 root))
|
|
'face 'font-lock-comment-face)))))
|
|
(insert "\n")
|
|
;; The write keys are only listed where they would work. A legend that
|
|
;; offered `e' on an expression root would be advertising a refusal.
|
|
(insert (propertize
|
|
(if (flan-inspect--writable)
|
|
"RET inspect l back g refresh TAB/n next p previous q quit\n"
|
|
"RET inspect e set C-c C-e edit l back g refresh TAB/n next p previous q quit\n")
|
|
'face 'shadow))
|
|
(goto-char (point-min))))
|
|
|
|
;;; The commands
|
|
|
|
(defun flan-inspect--value (root path)
|
|
"Ask the program what ROOT walked by PATH holds.
|
|
Returns (RENDERED . TYPE), TYPE nil when the reply did not name one. Signals
|
|
if the program refuses — and it is allowed to: a slot root over a frame whose
|
|
body was redefined is refused by the same fingerprint the locals listing is
|
|
refused by, and answering from somewhere else instead is the bug this second
|
|
root exists to fix."
|
|
(let ((r (pcase root
|
|
(`(:expr ,_)
|
|
(funcall flan-inspect-request-function
|
|
(list :op "eval-expr"
|
|
:code (flan-inspect--root-label root path)
|
|
:file "<inspect>")))
|
|
(`(:slot ,frame ,slot ,_name)
|
|
(funcall flan-inspect-request-function
|
|
;; `:path\=' is omitted rather than sent empty, because
|
|
;; Emacs cannot print an empty list as anything but
|
|
;; `nil\=', which is a symbol on the wire and not a list.
|
|
;; A missing `:path\=' is the slot itself, which is what
|
|
;; an empty path means.
|
|
(append (list :op "inspect" :frame frame :slot slot)
|
|
(when path
|
|
(list :path
|
|
(mapcar #'flan-inspect-wire-step path))))))
|
|
(`(:addr ,addr ,ty)
|
|
(when path
|
|
;; Refused rather than dropped. A path with a step silently
|
|
;; gone would render a *different* value and say nothing,
|
|
;; which is the failure this whole buffer is built to avoid.
|
|
(user-error
|
|
"flan: an address root has no path; it renders the pointer, \
|
|
and whether that may be followed is the answer"))
|
|
(funcall flan-inspect-request-function
|
|
(append (list :op "at" :addr addr)
|
|
(when ty (list :type ty)))))
|
|
(_ (user-error "flan: %S is not a root this inspector knows" root)))))
|
|
(unless (equal (plist-get r :status) "ok")
|
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))
|
|
(list :value (or (plist-get r :value)
|
|
(user-error
|
|
"flan: the program answered without a value for %s"
|
|
(flan-inspect--root-label root path)))
|
|
:type (plist-get r :type)
|
|
;; The stop the read happened at, where the reply carried one. It
|
|
;; travels with the value rather than being asked for separately,
|
|
;; because asked separately it would be a second question about a
|
|
;; different instant — and the whole use of the number is that it is
|
|
;; true of *what is on the screen*.
|
|
:at-stop (plist-get r :at-stop))))
|
|
|
|
(defun flan-inspect--show (root path &optional stack)
|
|
"Render ROOT walked by PATH in the inspector buffer, with STACK behind it."
|
|
(let ((answer (flan-inspect--value root path))
|
|
(buf (get-buffer-create flan-inspect-buffer)))
|
|
(with-current-buffer buf
|
|
(unless (derived-mode-p 'flan-inspect-mode) (flan-inspect-mode))
|
|
(setq flan-inspect--root root)
|
|
(setq flan-inspect--path path)
|
|
(setq flan-inspect--rendered (plist-get answer :value))
|
|
(setq flan-inspect--node (flan-inspect-parse flan-inspect--rendered))
|
|
(setq flan-inspect--type (plist-get answer :type))
|
|
(setq flan-inspect--at-stop (plist-get answer :at-stop))
|
|
(setq flan-inspect--stack stack)
|
|
(setq flan-inspect--editing nil)
|
|
;; Put back what editing turned off, here and not in the two commands
|
|
;; that leave it: this is the one funnel every drawing goes through, and
|
|
;; the mode body that set them in the first place does not run a second
|
|
;; time on a buffer that is already in the mode. Without it a listing
|
|
;; drawn after a commit is a listing you can yank into.
|
|
(setq buffer-read-only t)
|
|
(setq-local truncate-lines t)
|
|
(flan-inspect--render root path flan-inspect--node stack
|
|
flan-inspect--type))
|
|
(display-buffer buf)
|
|
buf))
|
|
|
|
(defun flan-inspect--expression-at-point ()
|
|
"The text of the expression point is on, or nil.
|
|
|
|
The innermost thing point is on, and not merely the one behind it: point in
|
|
the middle of a name is where a key pressed without looking lands, and
|
|
`backward-sexp\=' alone answers with the half of the name already typed past —
|
|
which reads as the command being broken rather than as point being one
|
|
character early. So the end of the thing under point is found first, and the
|
|
form is taken back from there; on an opening delimiter the form that opens
|
|
there is taken instead, which is the rule `flan-macroexpand\=' follows for the
|
|
same reason.
|
|
|
|
Innermost, so point on `enemies\=' inside `(len enemies)\=' takes `enemies\=' and
|
|
not the call — which is the right answer for a command that shows you one
|
|
value, and the enclosing call is a paren away in either direction.
|
|
|
|
Nil when there is nothing there to take, which is a buffer position with no
|
|
form at it at all."
|
|
(ignore-errors
|
|
(save-excursion
|
|
(skip-chars-forward " \t")
|
|
(if (looking-at-p "[([{]")
|
|
(buffer-substring-no-properties
|
|
(point) (progn (forward-sexp) (point)))
|
|
;; Inside a form: out to its end, so that the text taken is the whole
|
|
;; of it. Nothing to step over when point is already after one — at
|
|
;; whitespace, at a closing delimiter, or at the end of the buffer.
|
|
(unless (or (eobp)
|
|
(memq (char-syntax (char-after)) '(?\s ?> ?\))))
|
|
(forward-sexp))
|
|
(buffer-substring-no-properties
|
|
(save-excursion (backward-sexp) (point)) (point))))))
|
|
|
|
;;;###autoload
|
|
(defun flan-inspect (expr)
|
|
"Inspect the value of EXPR in the running program.
|
|
|
|
Interactively, the expression at point — no prompt, because the expression is
|
|
already written in the buffer and retyping it is the whole cost of the
|
|
command. With a prefix argument, or with nothing at point to take, the
|
|
minibuffer opens instead, pre-filled with whatever was there.
|
|
|
|
This is the expression root: EXPR is evaluated where the evaluator stands, so
|
|
it works on a running program but cannot say which frame it means. `i\=' in the
|
|
break buffer uses `flan-inspect-slot\=' for a local, for exactly that reason."
|
|
(interactive
|
|
(let ((at (flan-inspect--expression-at-point)))
|
|
(list (if (and at (not current-prefix-arg) (not (string-blank-p at)))
|
|
at
|
|
(read-string "Inspect: " at)))))
|
|
;; A new root, and therefore an empty stack. That is the whole of why `l\='
|
|
;; cannot walk out of one root into another: there is never an entry from a
|
|
;; different root left underneath it.
|
|
(flan-inspect--show (list :expr expr) nil nil))
|
|
|
|
;;;###autoload
|
|
(defun flan-inspect-slot (frame slot name)
|
|
"Inspect slot SLOT of stopped FRAME, which is called NAME.
|
|
The slot root. SLOT is an index and not a name, because a name is not an
|
|
identifier: two slots of one frame can share one, and a slot the daemon
|
|
refused is not in the listing at all, so neither the name nor the position in
|
|
the listing picks one out. The index is what `locals\=' puts on every line for
|
|
this."
|
|
(flan-inspect--show (list :slot frame slot name) nil nil))
|
|
|
|
(defvar flan-inspect-address-history nil
|
|
"Addresses `flan-inspect-address\=' has been given, most recent first.")
|
|
|
|
;;;###autoload
|
|
(defun flan-inspect-address (addr &optional type)
|
|
"Show what is at ADDR in the stopped program, as TYPE.
|
|
|
|
The address root. ADDR is a number — `#x7f…\=', or decimal — of the kind a
|
|
debugger, a valgrind report or a C shim\='s printf hands you, and which nothing
|
|
inside Flan will make for you: there is no integer-to-pointer cast in the
|
|
language, deliberately.
|
|
|
|
TYPE is optional, and leaving it out is the interesting half. A dev build
|
|
records the type at every allocation, so the registry already knows what was
|
|
put there and the daemon resolves that recorded name back to a type. Naming
|
|
one instead overrides it — for reading half a struct, or an element the table
|
|
recorded under a container\='s name — and the reply still carries what the
|
|
allocator wrote down, so the disagreement is never silent.
|
|
|
|
Refused while the program is running: whether an address is still live is
|
|
exactly what a running program is changing."
|
|
(interactive
|
|
(list (read-number "Address: "
|
|
(car (mapcar #'string-to-number
|
|
flan-inspect-address-history)))
|
|
(let ((s (read-string "As type (empty for what was recorded): ")))
|
|
(and (not (string-empty-p s)) s))))
|
|
(add-to-history 'flan-inspect-address-history (number-to-string addr))
|
|
(flan-inspect--show (list :addr addr type) nil nil))
|
|
|
|
(defun flan-inspect-into ()
|
|
"Go into the field or element at point.
|
|
Extends the path under the root this buffer already has; it never replaces the
|
|
root, which is what makes a mixed stack unconstructible."
|
|
(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 flan-inspect--root)))
|
|
(when why (user-error "flan: %s" why)))
|
|
;; A data type case's field, under an expression root. This is a refusal of
|
|
;; the *parent* and not of the value at point, which is why it is here and
|
|
;; not in `flan-inspect-refusal\=': a struct field that happens to hold a
|
|
;; data type is reached by an ordinary accessor and must stay enterable;
|
|
;; it is a field *of the data type itself* that has no accessor. `(match ...)\=' is
|
|
;; how a data type is opened in the language, and it binds names rather than
|
|
;; producing a value to send, so there is nothing to build here. The
|
|
;; renderer wrote the head as `Type.case\=', which is the one type spelling
|
|
;; with a dot in it — a package qualifies with a slash.
|
|
(let ((ty (plist-get flan-inspect--node :type)))
|
|
(when (and (not (eq (car-safe flan-inspect--root) :slot))
|
|
(stringp ty)
|
|
(string-match-p "\\." ty))
|
|
(user-error
|
|
"flan: %s"
|
|
(concat "a data type case's field: it is reached by (match ...) in the "
|
|
"language, not by an accessor, so there is no expression to "
|
|
"send. `i' on a local in the break buffer roots at the frame's "
|
|
"slot instead, and that root steps into it by offset"))))
|
|
;; The line carries the step that names the field; what the wire needs
|
|
;; beyond the name is the type it is a field *of*, and that is this
|
|
;; buffer's own node — the parent of the one at point. A data type's payload
|
|
;; sits at an offset that depends on the case, so `Type.case\=' has to
|
|
;; travel with the name. An option's payload has no name at all and is
|
|
;; the symbol `some\='.
|
|
(let* ((step (if (eq (plist-get flan-inspect--node :kind) 'option)
|
|
(list :some)
|
|
(pcase step
|
|
(`(:field ,name)
|
|
(list :field name (plist-get flan-inspect--node :type)))
|
|
(_ step))))
|
|
(path (append flan-inspect--path (list step)))
|
|
(stack (cons (cons flan-inspect--root
|
|
(cons flan-inspect--path (point)))
|
|
flan-inspect--stack)))
|
|
(flan-inspect--show flan-inspect--root path stack))))
|
|
|
|
(defun flan-inspect-pop ()
|
|
"Back to the value you came from, at the line you left.
|
|
The entry restored carries its own root, so this cannot land on a root other
|
|
than the one it was pushed under."
|
|
(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) (cadr top) rest)
|
|
(with-current-buffer flan-inspect-buffer
|
|
(goto-char (min (cddr top) (point-max))))))
|
|
|
|
(defun flan-inspect-refresh ()
|
|
"Read the same root and path again.
|
|
Deliberately a key rather than a timer: an expression root runs in the
|
|
program, and a root with an effect in it would fire once a second forever. A
|
|
slot root has no effect to repeat, but it can be refused — the program may
|
|
have resumed, or the frame's body may have been redefined — and a refusal
|
|
someone asked for reads very differently from one a timer produced."
|
|
(interactive)
|
|
(unless flan-inspect--root (user-error "flan: nothing is being inspected"))
|
|
(let ((p (point)))
|
|
(flan-inspect--show flan-inspect--root flan-inspect--path
|
|
flan-inspect--stack)
|
|
(with-current-buffer flan-inspect-buffer (goto-char (min p (point-max))))))
|
|
|
|
;;; Writing one back
|
|
|
|
;; SLY sets a value from its inspector, and the reason it is worth having here
|
|
;; is the reason the read half exists: the loop between "that field is wrong"
|
|
;; and "is it this value that fixes it" is the loop the whole dev story is
|
|
;; about, and changing the source and reloading answers a different question —
|
|
;; it answers what the *next* run does.
|
|
;;
|
|
;; Two ways in, and they are the same request underneath. `e' on a line sets
|
|
;; one field. `C-c C-e' turns the buffer into the value itself, you edit it
|
|
;; like text, and `C-c C-c' sends one write per leaf you changed. Both end in
|
|
;; `(:op "set")' with a list of (path, expression) edits, both are refused
|
|
;; whole if any one edit is impossible, and both redraw from what the program
|
|
;; holds afterwards rather than from what was typed.
|
|
;;
|
|
;; What makes writing defensible at all is that the program is stopped and
|
|
;; stays stopped. The daemon checks that, the agent checks it again on the
|
|
;; game thread at the moment the module is claimed, and the *stop* is named
|
|
;; rather than the state — so a program that resumed and stopped again between
|
|
;; the drawing and the commit refuses, instead of storing into the same slot
|
|
;; index of a stack nobody looked at.
|
|
|
|
(defun flan-inspect--writable (&optional what)
|
|
"Why this buffer cannot be written to, or nil if it can.
|
|
WHAT names the operation in the refusal."
|
|
(let ((what (or what "a write")))
|
|
(cond
|
|
((null flan-inspect--root) "nothing is being inspected")
|
|
;; The write verb roots at a frame slot and has no other root. That is
|
|
;; not an omission to be worked around here by sending `(set …)' to be
|
|
;; evaluated: an expression is evaluated wherever the evaluator stands and
|
|
;; at whatever moment it gets a frame boundary, which for a *write* means
|
|
;; storing into a program that is very possibly running — the one thing
|
|
;; this must not do. So it is refused, with the root that can.
|
|
((not (eq (car-safe flan-inspect--root) :slot))
|
|
(format "%s roots at a frame's slot, and this buffer is on %s. \
|
|
`i' on a local in the break buffer gives the root that can be written to"
|
|
what
|
|
(if (eq (car-safe flan-inspect--root) :addr)
|
|
"an address"
|
|
"an expression")))
|
|
((not (and (integerp flan-inspect--at-stop) (> flan-inspect--at-stop 0)))
|
|
(format "%s has to name the stop it was read at, and this drawing \
|
|
carries none. Press `g' to read it again" what))
|
|
(t nil))))
|
|
|
|
(defun flan-inspect--send (edits)
|
|
"Store EDITS, a list of (STEPS . CODE), into what this buffer is showing.
|
|
STEPS are relative to the buffer's own path. Redraws from the reply, which is
|
|
the program's storage read back and not an echo of what was sent."
|
|
(let* ((root flan-inspect--root)
|
|
(path flan-inspect--path)
|
|
(stack flan-inspect--stack)
|
|
(frame (nth 1 root))
|
|
(slot (nth 2 root))
|
|
(r (funcall
|
|
flan-inspect-request-function
|
|
(append
|
|
(list :op "set" :frame frame :slot slot)
|
|
(when path
|
|
(list :path (mapcar #'flan-inspect-wire-step path)))
|
|
(list :at-stop flan-inspect--at-stop
|
|
:edits
|
|
(mapcar
|
|
(lambda (e)
|
|
(append (list :code (cdr e))
|
|
(when (car e)
|
|
(list :path
|
|
(mapcar #'flan-inspect-wire-step
|
|
(car e))))))
|
|
edits))))))
|
|
(unless (equal (plist-get r :status) "ok")
|
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))
|
|
;; Redrawn from a fresh read rather than from the reply's value, even
|
|
;; though the reply carries one. The reply is the value at the path that
|
|
;; was written; the buffer may be showing a parent of it, and drawing the
|
|
;; child there would be the wrong value in the right place. `--show' also
|
|
;; picks up the new stop number, which the next commit needs.
|
|
(flan-inspect--show root path stack)
|
|
(message "flan: wrote %s" (plist-get r :value))
|
|
r))
|
|
|
|
(defun flan-inspect-set ()
|
|
"Set the field or element at point, or the whole value when point is not on one.
|
|
Prompts with what is there now; what you type is a Flan *expression*, checked
|
|
in the program against the type of the place it is going into — so `(+ 1 2)',
|
|
a string literal and a struct literal all work, and one that does not fit is
|
|
refused in the checker's own words."
|
|
(interactive)
|
|
(let ((why (flan-inspect--writable "setting a value")))
|
|
(when why (user-error "flan: %s" why)))
|
|
(let* ((step (get-text-property (point) 'flan-inspect-step))
|
|
(node (or (get-text-property (point) 'flan-inspect-node)
|
|
flan-inspect--node))
|
|
;; The step the wire wants carries the type it is a field *of*, the
|
|
;; same graft `flan-inspect-into' makes and for the same reason: a
|
|
;; data type's payload sits at an offset that depends on the case.
|
|
(steps (cond
|
|
((null step) nil)
|
|
((eq (plist-get flan-inspect--node :kind) 'option) (list '(:some)))
|
|
(t (list (pcase step
|
|
(`(:field ,name)
|
|
(list :field name
|
|
(plist-get flan-inspect--node :type)))
|
|
(_ step))))))
|
|
(where (flan-inspect--root-label
|
|
flan-inspect--root
|
|
(append flan-inspect--path steps)))
|
|
(now (flan-inspect--literal node))
|
|
(code (read-string (format "Set %s to: " where) now)))
|
|
(when (string-empty-p (string-trim code))
|
|
(user-error "flan: nothing to store"))
|
|
(flan-inspect--send (list (cons steps code)))))
|
|
|
|
;;; The buffer as the value
|
|
|
|
;; The second half, and the one that is not SLY's. A rendered Flan value is a
|
|
;; Flan literal — `(Point {.x 1.5 .y 2.5})' is what the renderer writes and
|
|
;; what the source would write — so the editable form of the value is the
|
|
;; value's own spelling, with no second notation to learn and nothing to
|
|
;; translate. Editing it is editing text; committing it is a diff.
|
|
;;
|
|
;; A diff and not a blast. A struct with one changed field sends one write for
|
|
;; that field, so the untouched fields are not rewritten with what was on the
|
|
;; screen — which matters exactly when it is hardest to see that it does: two
|
|
;; people, or a program and a person, touching the same value.
|
|
|
|
(defun flan-inspect--literal (node &optional indent)
|
|
"NODE as Flan source, laid out over lines from INDENT.
|
|
Round-trips through `flan-inspect-parse': what this writes is what that reads,
|
|
which is what makes the commit a comparison of two parses rather than a
|
|
comparison of two strings."
|
|
(let* ((indent (or indent 0))
|
|
(pad (make-string (+ indent 2) ?\s))
|
|
(kids (plist-get node :children)))
|
|
(pcase (plist-get node :kind)
|
|
('struct
|
|
(if (null kids)
|
|
(format "(%s {})" (plist-get node :text))
|
|
(concat "(" (plist-get node :text) " {"
|
|
(mapconcat
|
|
(lambda (c)
|
|
(concat "\n" pad "." (format "%s" (car c)) " "
|
|
(flan-inspect--literal (cdr c) (+ indent 2))))
|
|
kids "")
|
|
"})")))
|
|
('seq
|
|
(if (null kids) "[]"
|
|
(concat "["
|
|
(mapconcat
|
|
(lambda (c)
|
|
(concat "\n" pad (flan-inspect--literal (cdr c) (+ indent 2))))
|
|
kids "")
|
|
"]")))
|
|
('option
|
|
(concat "(some " (flan-inspect--literal (cdr (car kids)) indent) ")"))
|
|
(_ (plist-get node :text)))))
|
|
|
|
(defun flan-inspect--complete (node)
|
|
"Why NODE is not a whole value, or nil if it is.
|
|
The renderer stops at a depth of 4 and a span of 8, and what it writes when it
|
|
stops is `...'. A buffer holding one of those is a buffer where some of the
|
|
value is simply not present — and a commit read off it would look exactly like
|
|
somebody having deleted the part that was never written."
|
|
(cond
|
|
((eq (plist-get node :kind) 'trunc)
|
|
"the renderer stopped at its depth bound of 4 here, so part of this value \
|
|
was never written. Inspect the field that holds it, which re-roots the walk")
|
|
((plist-get node :truncated)
|
|
"the renderer stopped at its span bound of 8, so some of these are not in \
|
|
the buffer — and a commit read off it could not tell them from ones you had \
|
|
deleted")
|
|
(t (seq-some (lambda (c) (flan-inspect--complete (cdr c)))
|
|
(plist-get node :children)))))
|
|
|
|
(defun flan-inspect--diff (old new)
|
|
"One edit per leaf that differs between OLD and NEW.
|
|
Returns (EDITS . REFUSAL): EDITS is a list of (STEPS . CODE) and REFUSAL, when
|
|
it is non-nil, is why the two cannot be compared at all. A shape that changed
|
|
is a refusal and not an edit — adding a field to a struct or an element to an
|
|
array is not something a store can do, and quietly writing the leaves that did
|
|
line up would be the half-done version of what was asked."
|
|
(let ((edits nil) (why nil))
|
|
(cl-labels
|
|
((no (fmt &rest args) (unless why (setq why (apply #'format fmt args))))
|
|
(label (steps)
|
|
(if steps
|
|
(mapconcat (lambda (s)
|
|
(pcase s
|
|
(`(:field ,f . ,_) (concat "." f))
|
|
(`(:index ,i) (format "[%d]" i))
|
|
(`(:some) ".some")
|
|
(_ "")))
|
|
(reverse steps) "")
|
|
"this value"))
|
|
(walk (o n steps parent)
|
|
(let ((ok (plist-get o :kind)) (nk (plist-get n :kind)))
|
|
(cond
|
|
((equal o n) nil)
|
|
;; Asked of the *old* node and before the kinds are compared,
|
|
;; because the question is what the program wrote and not what
|
|
;; was typed over it. `<ptr>' and `<Name>' are what the renderer
|
|
;; writes when it has not written the value, so anything in their
|
|
;; place is an edit of nothing, whatever shape it now has.
|
|
((memq ok '(ptr opaque))
|
|
(no "%s is written as %s, which is what the renderer writes \
|
|
when it did not write the value — so there is nothing there to have changed"
|
|
(label steps) (plist-get o :text)))
|
|
((not (eq ok nk))
|
|
(no "%s was %s and is now %s: a store replaces a value, it \
|
|
does not change what kind of thing is there. Use `e' on it to set the whole \
|
|
value"
|
|
(label steps) (flan-inspect--kind-name ok)
|
|
(flan-inspect--kind-name nk)))
|
|
((memq ok '(struct option))
|
|
(if (and (eq ok 'struct)
|
|
(not (equal (plist-get o :text) (plist-get n :text))))
|
|
;; The head is the struct's name, and for a data type it is
|
|
;; `Type.case' — so a changed head is a changed *case*, which
|
|
;; is a change to the tag and not to any field under it.
|
|
(no "%s is a %s and the buffer says %s: which case a data \
|
|
type holds is the tag, not a field, so it is set whole. Use `e' on it"
|
|
(label steps) (plist-get o :text) (plist-get n :text))
|
|
(children o n steps)))
|
|
((eq ok 'seq)
|
|
(if (/= (length (plist-get o :children))
|
|
(length (plist-get n :children)))
|
|
(no "%s had %d element%s and the buffer has %d: adding or \
|
|
removing one is a change to the container, which is a thing the program does \
|
|
and not a thing a store does"
|
|
(label steps) (length (plist-get o :children))
|
|
(if (= 1 (length (plist-get o :children))) "" "s")
|
|
(length (plist-get n :children)))
|
|
(children o n steps)))
|
|
((equal (plist-get o :text) (plist-get n :text)) nil)
|
|
(t
|
|
(push (cons (reverse steps) (plist-get n :text)) edits))))
|
|
(ignore parent))
|
|
(children (o n steps)
|
|
(let ((ok (mapcar #'car (plist-get o :children)))
|
|
(nk (mapcar #'car (plist-get n :children))))
|
|
(if (not (equal ok nk))
|
|
(no "%s has %s in the buffer and %s in the program: a store \
|
|
writes what is there, it does not add or rename fields"
|
|
(label steps)
|
|
(if nk (mapconcat (lambda (k) (format "%s" k)) nk " ") "nothing")
|
|
(if ok (mapconcat (lambda (k) (format "%s" k)) ok " ") "nothing"))
|
|
(dolist (c (plist-get o :children))
|
|
(let ((step (if (integerp (car c))
|
|
(list :index (car c))
|
|
(if (eq (plist-get o :kind) 'option)
|
|
(list :some)
|
|
(list :field (car c) (plist-get o :type))))))
|
|
(walk (cdr c)
|
|
(cdr (assoc (car c) (plist-get n :children)))
|
|
(cons step steps) o)))))))
|
|
(walk old new nil nil))
|
|
;; A refusal voids the edits rather than sitting beside them. The walk
|
|
;; visits fields in order, so a struct with one good change and one
|
|
;; impossible one collects the good one before it reaches the other — and
|
|
;; handing that back with the refusal would make it possible for a caller
|
|
;; to send half of what was asked for. Nothing does; this is what makes
|
|
;; it not merely a convention.
|
|
(cons (and (null why) (nreverse edits)) why)))
|
|
|
|
(defun flan-inspect--kind-name (kind)
|
|
"KIND, said in words, for a refusal that has to name two of them."
|
|
(pcase kind
|
|
('struct "a struct") ('seq "a sequence") ('option "an option")
|
|
('ptr "a pointer") ('opaque "a type with no structure")
|
|
('trunc "the renderer's mark for where it stopped")
|
|
(_ "a single value")))
|
|
|
|
(defun flan-inspect-edit ()
|
|
"Turn this buffer into the value, editable.
|
|
What you get is the Flan literal the program wrote. Change it as text;
|
|
`C-c C-c' sends one write per leaf you changed and redraws from what the
|
|
program holds afterwards, `C-c C-k' throws the edit away."
|
|
(interactive)
|
|
(let ((why (flan-inspect--writable "editing the value")))
|
|
(when why (user-error "flan: %s" why)))
|
|
(when flan-inspect--editing (user-error "flan: this buffer is already open for editing"))
|
|
(let ((why (flan-inspect--complete flan-inspect--node)))
|
|
(when why (user-error "flan: %s" why)))
|
|
(let ((inhibit-read-only t))
|
|
(erase-buffer)
|
|
(insert (propertize (flan-inspect--root-label flan-inspect--root
|
|
flan-inspect--path)
|
|
'face 'font-lock-function-name-face)
|
|
"\n")
|
|
(when flan-inspect--type
|
|
(insert (propertize (format "%s\n" flan-inspect--type)
|
|
'face 'font-lock-type-face)))
|
|
(insert (propertize
|
|
"--- Editing. C-c C-c commits what you changed, C-c C-k abandons it.\n"
|
|
'face 'font-lock-comment-face))
|
|
(insert "\n")
|
|
;; Where the value starts, recorded rather than counted back to. The
|
|
;; header above is two lines or three depending on whether the daemon
|
|
;; named a type, and a count written here and again in the reader is two
|
|
;; places to keep in step for no gain.
|
|
(setq flan-inspect--editing (point-marker))
|
|
(set-marker-insertion-type flan-inspect--editing nil)
|
|
(insert (flan-inspect--literal flan-inspect--node))
|
|
(insert "\n")
|
|
(setq buffer-read-only nil)
|
|
(setq-local truncate-lines nil)
|
|
;; The header is not part of the value, so it is not part of what gets
|
|
;; parsed back — and it is fixed rather than merely un-parsed, because a
|
|
;; header edited by accident would otherwise read as the value having
|
|
;; grown a line.
|
|
(add-text-properties (point-min) (marker-position flan-inspect--editing)
|
|
'(read-only t front-sticky t))
|
|
(goto-char (point-max))
|
|
(forward-line -1)))
|
|
|
|
(defun flan-inspect--edited ()
|
|
"What the editable part of this buffer says, parsed."
|
|
(save-excursion
|
|
(goto-char (marker-position flan-inspect--editing))
|
|
(let ((text (buffer-substring-no-properties (point) (point-max))))
|
|
(when (string-empty-p (string-trim text))
|
|
(user-error "flan: there is nothing left in the buffer to commit"))
|
|
(let ((node (flan-inspect-parse text)))
|
|
(unless node
|
|
(user-error "flan: the buffer does not read as a Flan value"))
|
|
node))))
|
|
|
|
(defun flan-inspect-commit ()
|
|
"Send one write per leaf changed since this buffer was opened for editing."
|
|
(interactive)
|
|
(unless flan-inspect--editing
|
|
(user-error "flan: this buffer is a listing, not the value; `C-c C-e' opens it for editing"))
|
|
(let* ((old flan-inspect--node)
|
|
(new (flan-inspect--edited))
|
|
(d (flan-inspect--diff old new))
|
|
(edits (car d))
|
|
(why (cdr d)))
|
|
(when why (user-error "flan: %s" why))
|
|
(unless edits
|
|
;; Not silently nothing. A commit that found no change is a fact worth
|
|
;; saying — most often it means the edit went into the header, or into a
|
|
;; part of the buffer that is a summary rather than the value.
|
|
(user-error "flan: nothing in the buffer differs from what the program holds"))
|
|
(flan-inspect--send edits)))
|
|
|
|
(defun flan-inspect-abandon ()
|
|
"Throw the edit away and draw what the program holds."
|
|
(interactive)
|
|
(unless flan-inspect--editing
|
|
(user-error "flan: this buffer is not open for editing"))
|
|
(flan-inspect--show flan-inspect--root flan-inspect--path
|
|
flan-inspect--stack))
|
|
|
|
(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)
|
|
;; The write half. `e' for the one field under point, because that is the
|
|
;; letter Emacs uses for "edit the thing here" everywhere else a buffer
|
|
;; lists things; the prefixed pair for the mode, because `C-c C-c' is what
|
|
;; commits an editing buffer in this editor — message, log-edit and
|
|
;; org-src all — and `C-c C-k' is what abandons one.
|
|
(define-key map "e" #'flan-inspect-set)
|
|
(define-key map (kbd "C-c C-e") #'flan-inspect-edit)
|
|
(define-key map (kbd "C-c C-c") #'flan-inspect-commit)
|
|
(define-key map (kbd "C-c C-k") #'flan-inspect-abandon)
|
|
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
|