flan/emacs/flan-repl.el

;;; flan-repl.el --- A prompt for a running Flan program  -*- 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.

;; A buffer to type expressions at, sent to the program `flan dev' is running
;; and answered with the value they had *there*.  It adds no protocol and no
;; compiler support: every line goes through the same `eval-expr' request that
;; C-x C-e uses.
;;
;; Derived from `comint-mode', for the same reason `flan-mode' derives from
;; `lisp-mode': history, the input ring, and kill/yank behaviour already exist
;; and are not worth rewriting.  There is no subprocess behind it — the
;; "process" is a stub comint needs in order to have a prompt at all.
;;
;; Two things about it that are decisions, not accidents:
;;
;; - **It is program-scoped.**  A name typed here resolves against the running
;;   program's top-level namespace, so in sand you write `sim/settle' and not
;;   `settle'.  A buffer visiting a package's own file gets the alias applied
;;   for it, because the file says which package it belongs to; a prompt has no
;;   file and nothing to derive it from.
;;
;; - **A value and the program's output are different things** and arrive by
;;   different routes.  The value of the expression appears at the prompt;
;;   anything the program printed while evaluating it goes to *flan-output*,
;;   riding along on the same reply.  Showing them in one place would be
;;   convenient and wrong.

;;; Code:

(require 'comint)
(require 'flan-mode)
(require 'flan)

(defcustom flan-repl-buffer "*flan-repl*"
  "Name of the Flan REPL buffer."
  :type 'string
  :group 'flan)

(defcustom flan-repl-history-file (locate-user-emacs-file "flan-repl-history")
  "File the prompt's input history is kept in between sessions.
`locate-user-emacs-file' rather than a path of this file's own choosing: it
follows `user-emacs-directory', which is what `no-littering' and anyone who
has moved their state elsewhere have already redirected.  nil keeps history
for the session only."
  :type '(choice file (const :tag "Do not keep history between sessions" nil))
  :group 'flan)

(defcustom flan-repl-history-size 500
  "How many inputs the prompt remembers."
  :type 'integer
  :group 'flan)

(defconst flan-repl--history-separator "\n\f\n"
  "What separates two entries in the history file.
Comint separates them with a newline, which is also what is *inside* a form
typed over several lines: written that way, one such form comes back as
several broken ones.  A form feed alone on a line cannot occur inside a form,
so the file survives the round trip.
Let-bound around each call rather than set in the buffer, because
`comint-write-input-ring' reads this variable inside a temporary buffer where
a buffer-local value is not visible.")

(defvar flan-repl-prompt "flan> "
  "Prompt shown in `flan-repl-mode'.")

(defvar flan-repl-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "C-c C-o") #'flan-show-output)
    (define-key map (kbd "C-c C-d") #'flan-describe)
    (define-key map (kbd "C-c C-q") #'flan-disconnect)
    (define-key map (kbd "<up>") #'flan-repl-previous-input)
    (define-key map (kbd "<down>") #'flan-repl-next-input)
    map)
  "Keymap for `flan-repl-mode'.")

(define-derived-mode flan-repl-mode comint-mode "Flan-REPL"
  "Type expressions; they are evaluated in the running program.

\\{flan-repl-mode-map}"
  :syntax-table flan-mode-syntax-table
  (setq-local comint-prompt-regexp (concat "^" (regexp-quote flan-repl-prompt)))
  (setq-local comint-prompt-read-only t)
  (setq-local comint-input-sender #'flan-repl--send)
  ;; Nothing is echoed back by a process, because there is no process.
  (setq-local comint-process-echoes nil)
  ;; The prompt gets completion, eldoc and M-. for the same names a buffer
  ;; does, and against the same program: they read the client's cache, which
  ;; is program-scoped, which is exactly what a prompt is.
  (flan-setup)
  (setq-local font-lock-defaults '(flan-font-lock-keywords))
  (setq-local comint-input-ring-size flan-repl-history-size)
  (setq-local comint-input-ring-file-name
              (and flan-repl-history-file
                   (expand-file-name flan-repl-history-file)))
  ;; comint made the ring before this body ran, sized from the global value.
  (setq-local comint-input-ring (make-ring comint-input-ring-size))
  (let ((comint-input-ring-separator flan-repl--history-separator))
    ;; Silent: a first session has no file yet, and saying so is not news.
    (comint-read-input-ring t))
  (add-hook 'kill-buffer-hook #'flan-repl--save-history nil t))

;;; History

(defun flan-repl--history-entries (file)
  "How many entries FILE holds.
Counted rather than trusted to the ring, because the file may have been
written by another Emacs since this buffer read it."
  (if (not (file-readable-p file))
      0
    (with-temp-buffer
      (insert-file-contents file)
      (let ((n 0))
        (goto-char (point-min))
        (while (search-forward flan-repl--history-separator nil t)
          (setq n (1+ n)))
        n))))

(defun flan-repl--save-history ()
  "Write this buffer's input ring to `comint-input-ring-file-name'.
Refused in the two cases where writing loses more than it keeps: a ring with
nothing in it, which would empty the file, and a ring shorter than the file
already is, which is what a second Emacs having saved a longer history since
this buffer started looks like.  A write replaces the file whole, so either
would throw away somebody's session."
  (when (and comint-input-ring-file-name
             (ring-p comint-input-ring)
             (not (ring-empty-p comint-input-ring))
             (>= (ring-length comint-input-ring)
                 (flan-repl--history-entries comint-input-ring-file-name)))
    (let ((comint-input-ring-separator flan-repl--history-separator))
      (comint-write-input-ring))))

(defun flan-repl--save-all-history ()
  "Save every REPL buffer's history.
`kill-buffer-hook' does not run for a buffer Emacs is exiting out from under,
so quitting without killing the prompt first would otherwise lose the day."
  (dolist (buf (buffer-list))
    (with-current-buffer buf
      (when (derived-mode-p 'flan-repl-mode)
        (flan-repl--save-history)))))

;; Not in batch.  A batch Emacs exits through `kill-emacs' like any other, and
;; the prompt a test opened is nobody's session: the sweep would write the
;; person running the test their own history file, out of a ring made of
;; fixtures.
(unless noninteractive
  (add-hook 'kill-emacs-hook #'flan-repl--save-all-history))

;;; Recall

;; `<up>' at a prompt means history to nearly everyone who has used a shell,
;; and `M-p' means it to nearly nobody who has not used Emacs.  But the text
;; above the prompt is a transcript people scroll back through, and a blunt
;; binding would make that impossible — so the key is history only where there
;; is input for it to replace, and plain line motion everywhere else.  Inside a
;; form typed over several lines it still moves between them, and reaches
;; history from the first one.
;;
;; The search is prefix-filtered by what is already typed, which is comint's
;; `...-from-input' pair and the same thing a shell's up-arrow does.

(defun flan-repl--input-start ()
  "Where the text being typed begins, or nil if there is no process."
  (let ((proc (get-buffer-process (current-buffer))))
    (and proc (marker-position (process-mark proc)))))

(defun flan-repl--on-first-input-line-p ()
  "Is point on the first line of the input, with history above it?"
  (let ((start (flan-repl--input-start)))
    ;; `forward-line' rather than `line-beginning-position': the prompt is a
    ;; field, and field-constrained motion answers this question by accident
    ;; rather than by the rule meant here.
    (and start (<= start (point))
         (<= (save-excursion (forward-line 0) (point)) start))))

(defun flan-repl--on-last-input-line-p ()
  "Is point on the last line of the input?"
  (let ((start (flan-repl--input-start)))
    (and start (<= start (point))
         (save-excursion (forward-line 1) (eobp)))))

(defun flan-repl-previous-input (n)
  "Recall the previous matching input, or move up a line above the input."
  (interactive "p")
  (if (flan-repl--on-first-input-line-p)
      (progn
        ;; comint tells a continued search from a fresh one by looking at
        ;; `last-command' for its own name, which a wrapper's press never
        ;; leaves there: without the hand-off the second `<up>' searches again
        ;; from the entry the first one inserted and never moves.
        (setq this-command 'comint-previous-matching-input-from-input)
        (comint-previous-matching-input-from-input n))
    ;; Same reason in the other direction: `line-move' keeps the column it is
    ;; aiming for only while the line-motion commands follow each other.
    (setq this-command 'previous-line)
    ;; `previous-line' and not `forward-line': the byte compiler's advice
    ;; against it is for code moving over text, and this is a keypress asking
    ;; for what the key does everywhere else — visual lines, kept column.
    (with-no-warnings (previous-line n))))

(defun flan-repl-next-input (n)
  "Recall the next matching input, or move down a line above the input."
  (interactive "p")
  (if (flan-repl--on-last-input-line-p)
      (progn
        (setq this-command 'comint-next-matching-input-from-input)
        (comint-next-matching-input-from-input n))
    (setq this-command 'next-line)
    (with-no-warnings (next-line n))))

(defun flan-repl--complete-p (text)
  "Is TEXT a whole form?
Parens balanced and not inside a string or comment.  RET on a half-typed form
should open a line, not send something the reader will reject."
  (let ((state (with-temp-buffer
                 (set-syntax-table flan-mode-syntax-table)
                 (insert text)
                 (parse-partial-sexp (point-min) (point-max)))))
    (and (<= (nth 0 state) 0)            ; depth
         (not (nth 3 state))             ; in a string
         (not (nth 4 state)))))          ; in a comment

(defun flan-repl--output (text)
  "Insert TEXT into the REPL buffer above the next prompt."
  (let ((proc (get-buffer-process (current-buffer))))
    (comint-output-filter proc (concat text "\n" flan-repl-prompt))))

(defun flan-repl--send (_proc text)
  "Evaluate TEXT in the running program and show what it was."
  (let ((code (string-trim text)))
    (cond
     ((string-empty-p code) (flan-repl--output ""))
     (t
      (let ((reply (condition-case err
                       (flan--request
                        (list :op "eval-expr" :code code :file "<repl>"))
                     (error (list :status "error"
                                  :message (error-message-string err))))))
        (flan-repl--output
         (if (equal (plist-get reply :status) "ok")
             (or (plist-get reply :value) "")
           (concat "error: " (or (plist-get reply :message) "rejected")
                   (let ((loc (plist-get reply :loc)))
                     (if loc (concat "  (" loc ")") ""))))))))))

(defun flan-repl-return ()
  "Send the input if it is a whole form, otherwise open a line."
  (interactive)
  (let ((input (buffer-substring-no-properties
                (process-mark (get-buffer-process (current-buffer)))
                (point-max))))
    (if (flan-repl--complete-p input)
        (progn
          ;; `comint-send-input' sends the process mark to *point*, and
          ;; `comint-eol-on-send' carries it no further than the end of one
          ;; line.  Completeness above was judged over the whole input, so the
          ;; whole input is what goes: otherwise RET in the middle of a form
          ;; typed over several lines, or on one just recalled — history leaves
          ;; point where the typing stopped — sends a fragment the reader will
          ;; reject.
          (goto-char (point-max))
          (comint-send-input))
      (insert "\n"))))

(define-key flan-repl-mode-map (kbd "RET") #'flan-repl-return)

;;;###autoload
(defun flan-repl ()
  "Open a prompt on the program `flan dev' is running.
Connects first if it has to."
  (interactive)
  (unless (and flan--connection (process-live-p flan--connection))
    (call-interactively #'flan-connect))
  (let ((buf (get-buffer-create flan-repl-buffer)))
    (with-current-buffer buf
      (unless (derived-mode-p 'flan-repl-mode)
        (flan-repl-mode)
        ;; comint wants a process to hang a prompt and a process mark off.
        ;; There is nothing to run, so this one does nothing and is never
        ;; written to; every request goes over the daemon's socket instead.
        (let ((proc (start-process "flan-repl" buf "cat")))
          (set-process-query-on-exit-flag proc nil)
          (comint-output-filter proc flan-repl-prompt))))
    (pop-to-buffer buf)))

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