;;; 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.
;;
;;; 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 union 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 '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))
               ;; 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 union'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)' or `(:slot FRAME SLOT NAME)'.  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.

(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 "")))
    (_ "?")))

;;; 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
     (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)
  "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 (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