;;; flan-cnr.el --- What a stopped program is offering  -*- lexical-binding: t; -*-

;; `C-c C-b' is a `completing-read' over restart names.  That is the whole UI
;; for the one moment the dev loop exists to make survivable, and it is thin in
;; a way that is worth being specific about: it shows the names and nothing
;; else — not the condition's fields, not where the error was, not what the
;; frame between here and the restart was doing — and it will happily let you
;; choose a name that cannot be invoked.  This is the buffer that replaces it.
;;
;; Two sources, and they answer different questions.
;;
;; **SBCL** answers *what to put first*.  `invoke-debugger' prints the
;; condition, then `show-restarts', and stops.  The backtrace is a command you
;; type, not something it shows you.  That ordering is a claim: the restarts
;; are the decision in front of you and the stack is the explanation for it,
;; and a debugger that opens with forty frames has buried the decision under
;; the explanation.  So: condition, restarts, then the stack, and the stack's
;; locals folded away until asked for.
;;
;; `show-restarts' also numbers them and brackets the name — and omits the
;; bracket on a name already used further in.  That device is not decoration.
;; A restart is invoked by name; the name resolves to the innermost frame
;; offering it; so a second frame offering `retry' is real, is on the list, and
;; **cannot be chosen by name**.  spec-conditions.md §4 says exactly this about
;; Flan ("takes the first frame offering the name"), and `flan_find_restart'
;; does exactly this in the runtime.  Today's `completing-read' hides it: the
;; list has `retry' in it twice, picking either sends the string "retry", and
;; the inner one runs.  Here the shadowed entry is drawn and refused, by name,
;; with the reason.
;;
;; **CIDER's stacktrace buffer** answers *how it should behave*: frames that
;; expand in place, TAB to fold, everything reachable from the keyboard,
;; `q' to go.  What was not taken from it is the cause chain — CIDER walks
;; `ex-cause' because a JVM exception wraps another one, and a Flan condition
;; wraps nothing — and its filters, which exist because a JVM backtrace is
;; mostly frames nobody wrote.
;;
;; Everything this buffer cannot fill in is drawn as a section that says so, by
;; name, with what it would take.  A missing section is indistinguishable from
;; a section that happened to be empty, and only one of those is a fact about
;; the program.

;;; Code:

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

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

(defgroup flan-cnr nil
  "The conditions and restarts buffer."
  :prefix "flan-cnr-"
  :group 'flan)

(defcustom flan-cnr-buffer "*flan-conditions*"
  "Where the break buffer draws."
  :type 'string)

(defvar flan-cnr-request-function #'flan-dev--request
  "How this buffer reaches the daemon.
One plist in, the reply plist out.  A variable so the renderers can be driven
from fixtures, and so `flan-dev.el' is named in one place.")

;;; What is not available, and why

;; Said in one table rather than at each use, because these are claims about
;; the protocol and they should be revisable in one place when a verb lands.
;; Each carries its status in the same three words the design uses.

(defconst flan-cnr-unavailable
  '((layout
     . "which struct the class name refers to [needs a daemon op: `layout'. The field names and types are in `Tast.structs', which the daemon holds because it owns the build — no running program is involved. It is the one piece of this buffer that is a day's work on one side of the socket]")
    (value
     . "the break loop is handed the condition as an opaque pointer, and `break_loop' currently discards it; nothing at run time can render a value whose type it does not know [needs an agent verb: `condition', to stash and hand back the pointer, and a daemon-built render thunk aimed at it]")
    (site
     . "a restart frame carries its name and the hash matching uses, and no location [needs a location in the restart frame, which the compiler must emit]")
    (params
     . "restart arguments are checked at run time against a frame that does not record its arity [needs a field in the restart frame]")
    (stack
     . "nothing here is attached to the stopped program.  DWARF is not the gap and has not been for a while: `flan build --debug' emits it, `flan dev --debug' now builds the host and every redefinition module with it, and lldb walks a stack that crosses from a reloaded .so back into the host naming both sides' .flan files.  But this buffer reaches the program over the daemon's socket, and a socket cannot read another process's frames — the break loop stopped itself, it is not being debugged.  So this wants either an unwinder in the agent, beside `flan_rt.c', or lldb attached to the same pid and this buffer reading it [needs one of those two, not DWARF]")
    (locals
     . "same reason as the stack above it, plus a renderer aimed at an address rather than at an expression.  The names and types are in the DWARF now — a let-bound local is its own name there, not `s0' — so whatever walks the frames can read them; nothing is walking the frames [needs the same attachment, and the same thunk the condition's fields need]"))
  "Why a section of this buffer is empty, by name.")

(defun flan-cnr--why (key)
  (or (cdr (assq key flan-cnr-unavailable)) "not implemented"))

;;; Restarts, and which of them can actually be chosen

(defun flan-cnr-annotate-restarts (names)
  "Turn NAMES — innermost first — into what the buffer draws.
Each entry is (INDEX NAME SHADOWED-BY), where SHADOWED-BY is the index of the
earlier entry that owns the name, or nil.

This is §4's walk, computed here because it can be: `restart NAME' resolves
through `flan_find_restart', which returns the first frame whose hash matches,
so a name's second appearance is unreachable through the only verb there is.
Nothing new has to be asked of the program to know that — the order of the
list already says it."
  (let ((seen nil) (i -1))
    (mapcar (lambda (name)
              (setq i (1+ i))
              (let ((owner (cdr (assoc name seen))))
                (unless owner (push (cons name i) seen))
                (list i name owner)))
            names)))

;;; Drawing

(defvar-local flan-cnr--state nil
  "The plist this buffer was last drawn from.")
(defvar-local flan-cnr--open nil
  "Indices of the frames whose locals are showing.")

(defun flan-cnr--unavailable (key)
  (propertize (concat "  not available — " (flan-cnr--why key) "\n")
              'face 'font-lock-comment-face))

(defun flan-cnr--section (title)
  (insert (propertize (format "--- %s\n" title) 'face 'font-lock-comment-face)))

(defun flan-cnr--insert-condition (state)
  (let ((name (or (plist-get state :condition) "a condition")))
    (insert (propertize name 'face 'error))
    (insert (propertize "  — unhandled; stopped on the frame that erred, nothing unwound\n"
                        'face 'shadow)))
  (insert "\n")
  (flan-cnr--section "Condition fields:")
  ;; Two refusals, not one, and keeping them apart is the point. The *shape* of
  ;; a condition — its field names and their types — is in `Tast.structs',
  ;; which the daemon holds because it owns the build; no running program is
  ;; involved in answering it. Only the *values* need the pointer the break
  ;; loop was handed. So a field can be named and typed while its value is
  ;; refused, which is strictly more than saying nothing, and it is what tells
  ;; you whether the :path you were about to blame is even a field of this
  ;; condition.
  (let ((fields (plist-get state :fields)))
    (if (null fields)
        (insert (flan-cnr--unavailable 'layout))
      (let ((w (apply #'max 4 (mapcar (lambda (f) (length (nth 0 f))) fields)))
            (tw (apply #'max 4 (mapcar (lambda (f) (length (or (nth 1 f) ""))) fields))))
        (dolist (f fields)
          (let ((start (point))
                (name (nth 0 f)) (type (or (nth 1 f) "?")) (value (nth 2 f)))
            (insert (format "  :%s%s  %s%s  " name
                            (make-string (- w (length name)) ?\s)
                            (propertize type 'face 'font-lock-type-face)
                            (make-string (- tw (length type)) ?\s)))
            (insert (if value value
                      (propertize (concat "value not available — "
                                          (flan-cnr--why 'value))
                                  'face 'font-lock-comment-face))
                    "\n")
            (add-text-properties start (point)
                                 (list 'flan-cnr-inspect nil
                                       'mouse-face 'highlight)))))))
  (insert "\n"))

(defun flan-cnr--insert-restarts (state)
  (flan-cnr--section "Restarts (innermost first) — RET or a digit takes one:")
  (let* ((names (plist-get state :restarts))
         (rows (flan-cnr-annotate-restarts names)))
    (if (null rows)
        (insert (propertize
                 "  none are active. Nothing between the error and the top offered one; abort, or fix a body and reload\n"
                 'face 'font-lock-comment-face))
      (let ((w (apply #'max 4 (mapcar (lambda (r) (length (nth 1 r))) rows))))
        (dolist (r rows)
          (let* ((i (nth 0 r)) (name (nth 1 r)) (owner (nth 2 r))
                 (start (point)))
            ;; SBCL's bracket: it is there when the name reaches this frame and
            ;; gone when it does not.
            (insert (format " %2d: %s%s%s  " i
                            (if owner " " "[")
                            (propertize name 'face
                                        (if owner 'shadow 'font-lock-keyword-face))
                            (if owner " " "]")))
            (insert (make-string (- w (length name)) ?\s))
            (if owner
                (insert (propertize
                         (format "shadowed by %d — `restart' resolves a name to the innermost frame offering it, so this one cannot be taken by name [needs an agent verb: `restart-at INDEX']" owner)
                         'face 'font-lock-comment-face))
              (insert (propertize (flan-cnr--why 'site) 'face 'shadow)))
            (insert "\n")
            (add-text-properties start (point)
                                 (list 'flan-cnr-restart (if owner nil name)
                                       'flan-cnr-shadowed owner
                                       'flan-cnr-index i
                                       'mouse-face 'highlight))))))
    ;; Last, and on the same list, because it is the same decision: what you
    ;; pick when none of the restarts is the answer.
    (let ((start (point)))
      (insert (format " %2d: [%s]  " (length rows)
                      (propertize "abort" 'face 'error)))
      (insert (propertize "let the program die where it stopped; this ends `flan dev' too\n"
                          'face 'shadow))
      (add-text-properties start (point)
                           (list 'flan-cnr-abort t 'mouse-face 'highlight))))
  (insert "\n"))

(defun flan-cnr--insert-stack (state)
  (flan-cnr--section "Stack (innermost first) — TAB folds a frame's locals:")
  (let ((frames (plist-get state :stack)))
    (if (null frames)
        (insert (flan-cnr--unavailable 'stack))
      (let ((i -1))
        (dolist (fr frames)
          (setq i (1+ i))
          (let ((start (point))
                (open (memq i flan-cnr--open)))
            (insert (format " %2d: %s %s%s\n" i
                            (if open "v" ">")
                            (propertize (or (plist-get fr :fn) "?")
                                        'face 'font-lock-function-name-face)
                            (if (plist-get fr :loc)
                                (propertize (format "   %s" (plist-get fr :loc))
                                            'face 'shadow)
                              "")))
            (add-text-properties start (point)
                                 (list 'flan-cnr-frame i 'mouse-face 'highlight)))
          ;; Collapsed by default.  A stopped program has as many locals as it
          ;; has frames, and all of them at once is the backtrace problem again
          ;; one level down.
          (when (memq i flan-cnr--open)
            (let ((locals (plist-get fr :locals)))
              (if (null locals)
                  (insert (flan-cnr--unavailable 'locals))
                (dolist (l locals)
                  (let ((start (point)))
                    (insert (format "        %s %s = %s\n"
                                    (propertize (nth 1 l) 'face 'font-lock-type-face)
                                    (nth 0 l) (nth 2 l)))
                    (add-text-properties start (point)
                                         (list 'flan-cnr-inspect (nth 0 l)
                                               'mouse-face 'highlight)))))))))))
  (insert "\n"))

(defun flan-cnr--render (state)
  "Draw STATE, a plist, into the current buffer."
  (let ((inhibit-read-only t))
    (erase-buffer)
    (setq flan-cnr--state state)
    ;; SBCL's order: what happened, what you can do about it, then why.
    (flan-cnr--insert-condition state)
    (flan-cnr--insert-restarts state)
    (flan-cnr--insert-stack state)
    (insert (propertize
             "RET/0-9 take  a abort  TAB fold a frame  i inspect  g refresh  q quit\n"
             'face 'shadow))
    (goto-char (point-min))))

;;; Commands

(defun flan-cnr--refuse-shadowed ()
  (user-error
   "flan: restart %d is shadowed by %d; `restart' takes a name, and this name reaches the inner frame. Taking this one needs an index verb the daemon does not have"
   (get-text-property (point) 'flan-cnr-index)
   (get-text-property (point) 'flan-cnr-shadowed)))

(defun flan-cnr-take ()
  "Take the restart on this line."
  (interactive)
  (cond
   ((get-text-property (point) 'flan-cnr-abort) (flan-cnr-abort))
   ((get-text-property (point) 'flan-cnr-shadowed) (flan-cnr--refuse-shadowed))
   ((get-text-property (point) 'flan-cnr-restart)
    (flan-cnr--invoke (get-text-property (point) 'flan-cnr-restart)))
   ((get-text-property (point) 'flan-cnr-frame) (flan-cnr-toggle-frame))
   (t (user-error "flan: nothing to take on this line"))))

(defun flan-cnr--invoke (name)
  (let ((r (funcall flan-cnr-request-function (list :op "restart" :name name))))
    (if (equal (plist-get r :status) "ok")
        ;; Accepted, not resumed — the choice is validated against the stopped
        ;; stack and taken when that thread next comes round its loop.  So the
        ;; buffer says so and goes, rather than redrawing a state that is about
        ;; to stop being true.
        (progn (message "flan: %s — %s" name (or (plist-get r :note) "accepted"))
               (quit-window))
      (user-error "flan: %s" (or (plist-get r :message) "refused")))))

(defun flan-cnr-take-number (n)
  "Take restart number N, as SBCL's debugger does."
  (interactive (list (- last-command-event ?0)))
  (save-excursion
    (goto-char (point-min))
    (let ((found nil))
      (while (and (not found) (not (eobp)))
        (when (and (equal n (get-text-property (point) 'flan-cnr-index))
                   (or (get-text-property (point) 'flan-cnr-restart)
                       (get-text-property (point) 'flan-cnr-shadowed)))
          (setq found t))
        (unless found (forward-line 1)))
      (if found (flan-cnr-take)
        ;; The abort line's number is one past the last restart.
        (let ((names (plist-get flan-cnr--state :restarts)))
          (if (= n (length names)) (flan-cnr-abort)
            (user-error "flan: there is no restart %d" n)))))))

(defun flan-cnr-abort ()
  "Let the stopped program die where it stopped."
  (interactive)
  (let ((r (funcall flan-cnr-request-function '(:op "abort"))))
    (if (equal (plist-get r :status) "ok")
        (progn (message "flan: %s" (or (plist-get r :note) "aborted")) (quit-window))
      (user-error "flan: %s" (or (plist-get r :message) "refused")))))

(defun flan-cnr-toggle-frame ()
  "Show or hide this frame's locals."
  (interactive)
  (let ((i (get-text-property (point) 'flan-cnr-frame)))
    (unless i (user-error "flan: point is not on a frame"))
    (setq flan-cnr--open
          (if (memq i flan-cnr--open) (delq i flan-cnr--open)
            (cons i flan-cnr--open)))
    (let ((line (line-number-at-pos)))
      (flan-cnr--render flan-cnr--state)
      (goto-char (point-min))
      (forward-line (1- line)))))

(defun flan-cnr-inspect ()
  "Open the inspector on the thing at point."
  (interactive)
  (let ((expr (get-text-property (point) 'flan-cnr-inspect)))
    (unless expr
      (user-error "flan: %s" (flan-cnr--why 'locals)))
    (require 'flan-inspect)
    (flan-inspect expr)))

(defun flan-cnr-refresh ()
  "Ask the program again what it is offering."
  (interactive)
  (flan-cnr-show))

(defun flan-cnr-next ()
  "Move to the next line that does something."
  (interactive)
  (let ((p (point)))
    (forward-line 1)
    (while (and (not (eobp)) (not (flan-cnr--actionable-p (point))))
      (forward-line 1))
    (when (eobp) (goto-char p))))

(defun flan-cnr-previous ()
  "Move to the previous line that does something."
  (interactive)
  (let ((p (point)))
    (forward-line -1)
    (while (and (not (bobp)) (not (flan-cnr--actionable-p (point))))
      (forward-line -1))
    (unless (flan-cnr--actionable-p (point)) (goto-char p))))

(defun flan-cnr--actionable-p (pos)
  (or (get-text-property pos 'flan-cnr-restart)
      (get-text-property pos 'flan-cnr-shadowed)
      (get-text-property pos 'flan-cnr-abort)
      (get-text-property pos 'flan-cnr-frame)
      (get-text-property pos 'flan-cnr-inspect)))

(defvar flan-cnr-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "RET") #'flan-cnr-take)
    (define-key map [mouse-1] #'flan-cnr-take)
    (define-key map (kbd "TAB") #'flan-cnr-next)
    (define-key map [backtab] #'flan-cnr-previous)
    (define-key map "n" #'flan-cnr-next)
    (define-key map "p" #'flan-cnr-previous)
    (define-key map "f" #'flan-cnr-toggle-frame)
    (define-key map "i" #'flan-cnr-inspect)
    (define-key map "a" #'flan-cnr-abort)
    (define-key map "g" #'flan-cnr-refresh)
    (define-key map "q" #'quit-window)
    ;; Numbered, as SBCL's are, and for SBCL's reason: the names are not
    ;; unique, so the number is the only unambiguous handle a person has.
    (dotimes (i 10)
      (define-key map (kbd (number-to-string i)) #'flan-cnr-take-number))
    map)
  "Keys in `flan-cnr-mode'.")

(define-derived-mode flan-cnr-mode special-mode "flan-break"
  "What a stopped Flan program is offering."
  (setq buffer-read-only t))

(defun flan-cnr-state-from-reply (reply)
  "The buffer's state, out of a `break' REPLY.
Everything this cannot fill in is left nil deliberately: the renderer draws a
section saying why rather than leaving one out, and a section that is absent
cannot be told from one that is empty."
  (list :condition (plist-get reply :condition)
        :restarts (plist-get reply :restarts)
        ;; Both nil deliberately: `break' answers a class name and a list of
        ;; restart names, and nothing else exists to put here yet. The renderer
        ;; draws a section saying why rather than leaving one out.
        :fields nil
        :stack nil
        :locals nil))

;;;###autoload
(defun flan-cnr-show ()
  "Show what the stopped program is offering, in a buffer.
Refuses while the program is running, by name: there is no restart stack to
walk from a running program."
  (interactive)
  (let ((r (funcall flan-cnr-request-function '(:op "break"))))
    (unless (equal (plist-get r :status) "ok")
      (user-error "flan: %s" (or (plist-get r :message) "refused")))
    (unless (plist-get r :stopped)
      (user-error "flan: the program is running; there is no restart stack to walk"))
    (let ((buf (get-buffer-create flan-cnr-buffer)))
      (with-current-buffer buf
        (unless (derived-mode-p 'flan-cnr-mode) (flan-cnr-mode))
        (flan-cnr--render (flan-cnr-state-from-reply r)))
      (pop-to-buffer buf)
      buf)))

(provide 'flan-cnr)
;;; flan-cnr.el ends here