;;; flan-inspect.el --- Navigate a running program's values  -*- lexical-binding: t; -*-

;; `C-x C-e' renders a value once and puts it in the echo area.  This is the
;; interactive version of the same walk: the fields laid out one per line, RET
;; to go into one, `l' to come back, `g' to read it again.  CIDER's inspector,
;; adapted — and the adaptation is the whole design, so it is worth stating
;; what changed and why.
;;
;; CIDER's inspector keeps its stack **on the server**.  `inspect-push' hands
;; the middleware an index and the middleware walks into the object it is
;; already holding; the client's own stack is only remembered point positions.
;; That is available to it because a JVM value can be retained: the middleware
;; keeps a reference and the collector leaves it alone.
;;
;; Nothing here can do that.  A Flan value has no header, the thunk that
;; rendered it is `dlclose'd the moment it returns, and there is no heap to
;; retain anything in.  So the stack is a stack of **expressions**, on this
;; side, and going into a field means sending a *different expression* —
;; `(.pos b)' where the last one was `b'.  Two consequences, one good and one
;; that has to be said out loud:
;;
;;   the view is never stale.  Every step and every `g' reads the program as
;;   it is now, at a frame boundary it agreed to stop on.  CIDER's inspector
;;   shows you the object as it was when you pushed;
;;
;;   and the root expression runs again on every step.  Appending a field
;;   accessor to it is pure, but the root need not be — `(spawn-enemy)' as a
;;   root spawns one per keystroke.  Which is why there is no auto-refresh and
;;   why `g' is a key someone presses.
;;
;; The other thing this buys, and the reason it is worth having at all next to
;; `C-x C-e': the renderer bounds its walk at depth 4 and span 8
;; (lib/session.ml).  A field past either bound comes back as `...' and no
;; amount of squinting at the echo area recovers it.  Re-rooting the walk at
;; that field renders it from depth 0 — the bound moves with you.

;;; Code:

(require 'seq)
(require 'subr-x)

(declare-function flan-dev--request "flan-dev" (form))

(defgroup flan-inspect nil
  "Navigating values in a running Flan program."
  :prefix "flan-inspect-"
  :group 'flan)

(defcustom flan-inspect-buffer "*flan-inspect*"
  "Where the inspector draws."
  :type 'string)

(defvar flan-inspect-request-function #'flan-dev--request
  "How the inspector reaches the program.
Called with one plist — a request — and returning the reply plist.  It is a
variable rather than a direct call so that a test can hand the renderers a
reply without a daemon behind them, and so that this file names
`flan-dev.el' in exactly one place.")

;;; Reading what the renderer wrote

;; The value comes back as a string, and that string is very nearly an
;; s-expression — `(Blob {:id 7 :pos (V {:x 1.5 :y 0})})'.  Nearly, because
;; Emacs' `read' has no `{', so it is parsed here instead.  The grammar is
;; small and fixed by `Session.render' (lib/session.ml), and every case below
;; names the line of it that produces it.
;;
;;   (Name {:f V :f V})   a struct, with ` ...' before the `}' if the walk hit
;;                        its span bound of 8 fields
;;   [ V V V]             an array or a slice, ` ...' likewise
;;   (some V) / none      an option
;;   <ptr>                a pointer, never followed
;;   <Name>               a named type the walk had no structure for
;;   ...                  the depth bound, 4, reached at this position
;;   :name                an enum member, or its number if it matched none
;;   "…"                  a string, escaped in C
;;   true / false / ()    bool, and the value of a Unit expression
;;   1.5 / 7 / 18446…     a number
;;
;; A node is a plist: :kind, :text (what the renderer wrote for it), :type
;; where there is one, and :children as a list of (LABEL . NODE).

(defun flan-inspect--skip-space (s i)
  (while (and (< i (length s)) (memq (aref s i) '(?\s ?\n ?\t))) (setq i (1+ i)))
  i)

(defun flan-inspect--read-string (s i)
  "Read a quoted string starting at I (which is the opening quote)."
  (let ((out (list ?\")) (i (1+ i)) (done nil))
    (while (and (not done) (< i (length s)))
      (let ((c (aref s i)))
        (cond ((eq c ?\\)
               (setq i (1+ i))
               (when (< i (length s)) (push (aref s i) out) (setq i (1+ i))))
              ((eq c ?\") (push ?\" out) (setq i (1+ i)) (setq done t))
              (t (push c out) (setq i (1+ i))))))
    (cons (list :kind 'atom :text (concat (nreverse out))) i)))

(defun flan-inspect--read-atom (s i)
  "Read a bare token at I: a number, a keyword, `true', `none', `...'."
  (let ((start i))
    (while (and (< i (length s))
                (not (memq (aref s i) '(?\s ?\n ?\t ?\) ?\] ?\}))))
      (setq i (1+ i)))
    (let ((text (substring s start i)))
      (cons (list :kind (if (equal text "...") 'trunc 'atom) :text text) i))))

(defun flan-inspect--read-angle (s i)
  "Read `<ptr>' or `<Name>' at I."
  (let ((end (or (string-match ">" s i) (1- (length s)))))
    (let ((text (substring s i (1+ end))))
      (cons (list :kind (if (equal text "<ptr>") 'ptr 'opaque) :text text)
            (1+ end)))))

(defun flan-inspect--read-seq (s i)
  "Read `[ V V]' at I, which is `[' — an array or a slice."
  (let ((i (1+ i)) (kids nil) (n 0) (more nil) (done nil))
    (while (not done)
      (setq i (flan-inspect--skip-space s i))
      (cond
       ((>= i (length s)) (setq done t))
       ((eq (aref s i) ?\]) (setq i (1+ i)) (setq done t))
       (t (let ((r (flan-inspect--read s i)))
            (setq i (cdr r))
            ;; A bare `...' inside a sequence is the renderer saying it stopped,
            ;; not an element.  It is the last thing it writes either way.
            (if (eq (plist-get (car r) :kind) 'trunc)
                (setq more t)
              (push (cons n (car r)) kids)
              (setq n (1+ n)))))))
    (cons (list :kind 'seq
                :text (format "%d element%s%s" n (if (= n 1) "" "s")
                              (if more ", and more the renderer did not write" ""))
                :truncated more
                :children (nreverse kids))
          i)))

(defun flan-inspect--read-struct (s i)
  "Read `(Name {…})' or `(some V)' at I, which is `('."
  (let ((j (1+ i)))
    (let ((start j))
      (while (and (< j (length s)) (not (memq (aref s j) '(?\s ?\))))) (setq j (1+ j)))
      (let ((head (substring s start j)))
        (cond
         ;; (some V).  There is no accessor form in Flan that reaches an
         ;; option's payload — the compiler gets at it as field 1 and nothing
         ;; in the surface language does — so this parses, prints, and refuses
         ;; to be entered.
         ((equal head "some")
          (let* ((r (flan-inspect--read s (flan-inspect--skip-space s j)))
                 (k (flan-inspect--skip-space s (cdr r))))
            (cons (list :kind 'option :text "some" :type "Option"
                        :children (list (cons "some" (car r))))
                  (if (and (< k (length s)) (eq (aref s k) ?\))) (1+ k) k))))
         (t
          ;; `(Name {' then `:field VALUE' pairs, then `})'.
          (setq j (flan-inspect--skip-space s j))
          (when (and (< j (length s)) (eq (aref s j) ?\{)) (setq j (1+ j)))
          (let ((kids nil) (more nil) (done nil))
            (while (not done)
              (setq j (flan-inspect--skip-space s j))
              (cond
               ((>= j (length s)) (setq done t))
               ((eq (aref s j) ?\}) (setq j (1+ j)) (setq done t))
               ((eq (aref s j) ?:)
                (let ((start j))
                  (while (and (< j (length s)) (not (memq (aref s j) '(?\s ?\}))))
                    (setq j (1+ j)))
                  (let ((name (substring s (1+ start) j))
                        (r (flan-inspect--read s (flan-inspect--skip-space s j))))
                    (setq j (cdr r))
                    (push (cons name (car r)) kids))))
               (t (let ((r (flan-inspect--read s j)))
                    (setq j (cdr r))
                    (if (eq (plist-get (car r) :kind) 'trunc)
                        (setq more t)
                      ;; Not a `:field' and not `...'.  Rather than guess, keep
                      ;; it where it was written.
                      (push (cons "?" (car r)) kids))))))
            (setq j (flan-inspect--skip-space s j))
            (when (and (< j (length s)) (eq (aref s j) ?\))) (setq j (1+ j)))
            (cons (list :kind 'struct :text head :type head
                        :truncated more
                        :children (nreverse kids))
                  j))))))))

(defun flan-inspect--read (s i)
  "Read one rendered value out of S at I.  Returns (NODE . NEXT-INDEX)."
  (let ((i (flan-inspect--skip-space s i)))
    (if (>= i (length s))
        (cons (list :kind 'atom :text "") i)
      (pcase (aref s i)
        (?\( (flan-inspect--read-struct s i))
        (?\[ (flan-inspect--read-seq s i))
        (?\" (flan-inspect--read-string s i))
        (?< (flan-inspect--read-angle s i))
        (_ (flan-inspect--read-atom s i))))))

(defun flan-inspect-parse (rendered)
  "Parse RENDERED — what the daemon put in a reply's :value — into a node."
  (car (flan-inspect--read (or rendered "") 0)))

;;; Where a field is, said in Flan

;; A step is not an index into something remembered; it is a piece of source.
;; `(.pos b)' and `(at (.tags b) 2)' are expressions the program can be handed
;; exactly as a person would type them, which is what makes the whole thing
;; work without a handle to retain.

(defun flan-inspect-step-expr (expr step)
  "The Flan expression reaching STEP inside EXPR."
  (pcase step
    (`(:field ,name) (format "(.%s %s)" name expr))
    (`(:index ,i) (format "(at %s %d)" expr i))
    (_ expr)))

;;; Why a thing cannot be entered

;; Every refusal is by name and carries its reason, because the alternative —
;; RET doing nothing on some lines and something on others — is a UI that
;; teaches you nothing about the language.

(defun flan-inspect-refusal (node)
  "Why NODE cannot be inspected, or nil if it can."
  (pcase (plist-get node :kind)
    ('struct (and (null (plist-get node :children))
                  "a struct with no fields the renderer could reach"))
    ('seq (and (null (plist-get node :children))
               "an empty sequence: there is no element to go into"))
    ('option
     "an option's payload: Flan has no accessor form that reaches it, so there is no expression to send")
    ('ptr
     "a pointer: the renderer never follows one, and dereferencing a pointer on your behalf is not safe")
    ('trunc
     "truncated: the walk stopped at its depth bound of 4. Inspect the field that holds it, which re-roots the walk")
    ('opaque
     (format "%s: the walk had no structure for this type, so there are no fields to show"
             (plist-get node :text)))
    ('atom (format "%s is an atom; it has no fields" (plist-get node :text)))
    (_ "not something this inspector knows how to enter")))

;;; Drawing it

(defvar-local flan-inspect--stack nil
  "Where we have been: a list of (EXPR . POINT), innermost last-pushed first.")
(defvar-local flan-inspect--expr nil "The expression this buffer is showing.")
(defvar-local flan-inspect--node nil "Its parsed value.")

(defun flan-inspect--label (child)
  (let ((k (car child)))
    (if (integerp k) (format "%d." k) (format ":%s" k))))

(defun flan-inspect--summary (node)
  "One line for NODE, as it appears beside its label."
  (pcase (plist-get node :kind)
    ('struct (format "(%s …%s)" (plist-get node :type)
                     (let ((n (length (plist-get node :children))))
                       (format " %d field%s" n (if (= n 1) "" "s")))))
    ('seq (plist-get node :text))
    ('option (format "(some …)"))
    (_ (plist-get node :text))))

(defun flan-inspect--render (expr node stack)
  "Draw NODE, reached by EXPR, with STACK behind it."
  (let ((inhibit-read-only t))
    (erase-buffer)
    (insert (propertize expr 'face 'font-lock-function-name-face) "\n")
    (insert (propertize
             (pcase (plist-get node :kind)
               ('struct (format "a %s\n" (plist-get node :type)))
               ('seq (format "%s\n" (plist-get node :text)))
               ('option "an option\n")
               ('ptr "a pointer — never followed\n")
               (_ (format "%s\n" (plist-get node :text))))
             'face 'font-lock-type-face))
    ;; The stack made visible.  CIDER keeps it and does not show it; here it is
    ;; the difference between a value and *which* value, and the thing that was
    ;; typed at the root is often several steps back by now.
    (when stack
      (insert (propertize
               (concat "  via  "
                       (string-join (reverse (mapcar #'car stack)) "  >  ")
                       "  >  here\n")
               'face 'shadow)))
    (insert "\n")
    (let ((kids (plist-get node :children)))
      (cond
       (kids
        (insert (propertize (if (eq (plist-get node :kind) 'seq)
                                "--- Elements:\n" "--- Fields:\n")
                            'face 'font-lock-comment-face))
        (let ((w (apply #'max 4 (mapcar (lambda (c) (length (flan-inspect--label c))) kids))))
          (dolist (c kids)
            (let* ((label (flan-inspect--label c))
                   (child (cdr c))
                   (step (if (integerp (car c)) (list :index (car c))
                           (list :field (car c))))
                   (start (point)))
              (insert (format "  %s%s  " label
                              (make-string (- w (length label)) ?\s)))
              (insert (flan-inspect--summary child) "\n")
              (add-text-properties
               start (point)
               (list 'flan-inspect-step step
                     'flan-inspect-node child
                     'mouse-face 'highlight)))))
        (when (plist-get node :truncated)
          (insert (propertize
                   "  ...  the renderer stopped at its span bound of 8; the rest was not written\n"
                   'face 'font-lock-warning-face))))
       (t
        (insert (propertize
                 (format "Nothing to go into: %s\n" (flan-inspect-refusal node))
                 'face 'font-lock-comment-face)))))
    (insert "\n")
    (insert (propertize
             "RET inspect  l back  g refresh  TAB/n next  p previous  q quit\n"
             'face 'shadow))
    (goto-char (point-min))))

;;; The commands

(defun flan-inspect--value (expr)
  "Ask the program for EXPR's value, rendered.  Signals if it refuses."
  (let ((r (funcall flan-inspect-request-function
                    (list :op "eval-expr" :code expr :file "<inspect>"))))
    (unless (equal (plist-get r :status) "ok")
      (user-error "flan: %s" (or (plist-get r :message) "refused")))
    (or (plist-get r :value)
        (user-error "flan: the program answered without a value for %s" expr))))

(defun flan-inspect--show (expr &optional stack)
  "Render EXPR in the inspector buffer, with STACK behind it."
  (let ((value (flan-inspect--value expr))
        (buf (get-buffer-create flan-inspect-buffer)))
    (with-current-buffer buf
      (unless (derived-mode-p 'flan-inspect-mode) (flan-inspect-mode))
      (setq flan-inspect--expr expr)
      (setq flan-inspect--node (flan-inspect-parse value))
      (setq flan-inspect--stack stack)
      (flan-inspect--render expr flan-inspect--node stack))
    (display-buffer buf)
    buf))

;;;###autoload
(defun flan-inspect (expr)
  "Inspect the value of EXPR in the running program.
Interactively, the expression before point, or one you type."
  (interactive
   (list (read-string "Inspect: "
                      (ignore-errors
                        (buffer-substring-no-properties
                         (save-excursion (backward-sexp) (point)) (point))))))
  (flan-inspect--show expr nil))

(defun flan-inspect-into ()
  "Go into the field or element at point."
  (interactive)
  (let ((step (get-text-property (point) 'flan-inspect-step))
        (node (get-text-property (point) 'flan-inspect-node)))
    (unless step (user-error "flan: nothing to inspect on this line"))
    (let ((why (flan-inspect-refusal node)))
      (when why (user-error "flan: %s" why)))
    (let ((expr (flan-inspect-step-expr flan-inspect--expr step))
          (stack (cons (cons flan-inspect--expr (point)) flan-inspect--stack)))
      (flan-inspect--show expr stack))))

(defun flan-inspect-pop ()
  "Back to the value you came from, at the line you left."
  (interactive)
  (unless flan-inspect--stack
    (user-error "flan: this is the root; there is nothing behind it"))
  (let* ((top (car flan-inspect--stack))
         (rest (cdr flan-inspect--stack)))
    (flan-inspect--show (car top) rest)
    (with-current-buffer flan-inspect-buffer
      (goto-char (min (cdr top) (point-max))))))

(defun flan-inspect-refresh ()
  "Read the same expression again.
Deliberately a key rather than a timer: the expression runs in the program,
and a root with an effect in it would fire once a second forever."
  (interactive)
  (unless flan-inspect--expr (user-error "flan: nothing is being inspected"))
  (let ((p (point)))
    (flan-inspect--show flan-inspect--expr flan-inspect--stack)
    (with-current-buffer flan-inspect-buffer (goto-char (min p (point-max))))))

(defun flan-inspect--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