Joseph Ferano
8a94f16acd
Its stdout is a pipe into the daemon now, and whatever it printed since the last reply rides along with the next one into *flan-output*. Arriving with a reply rather than by a separate request is the point: the output an evaluation itself caused is the output anyone wants to see. Draining that pipe is a liveness requirement, not a nicety. A pipe nobody reads fills at 64K and the next write blocks the program forever, so it is read from the accept loop's select whether or not an editor is asking, and the buffer is capped - a program printing every frame must not grow the daemon without limit, and the newest text is the useful end. test_dev read the program's transcript off the daemon's stdout, which is no longer where it goes; it collects :output from replies instead, which is also what the editor does. The emacs test moved to a fixture that keeps running, since it now evaluates more times than the old one had reloads to give.
263 lines
11 KiB
EmacsLisp
263 lines
11 KiB
EmacsLisp
;;; flan-dev.el --- Talk to a running Flan program -*- lexical-binding: t; -*-
|
|
|
|
;; The editor half of Flan's dev loop. `flan dev program.flan' compiles the
|
|
;; program, launches it, and listens on .flan-dev.sock beside the source; this
|
|
;; connects to that socket and sends it forms.
|
|
;;
|
|
;; C-c C-c recompiles the top-level form at point and installs it in the
|
|
;; running program, at that program's next frame boundary. Call sites compiled
|
|
;; before the new body existed follow it, and the program's state — its globals
|
|
;; — is untouched. C-c C-k does the same for a whole buffer.
|
|
;;
|
|
;; The protocol is one s-expression per message, length framed. That is why
|
|
;; there is no parser here: `prin1' writes a request and `read' reads a reply.
|
|
;;
|
|
;; C-x C-e evaluates the expression before point *in the running program* and
|
|
;; shows its value. That is a different primitive from redefining a name:
|
|
;; there is nothing to install a body into, so the expression is wrapped in a
|
|
;; thunk the program runs at its next frame boundary. Only scalars, bool and
|
|
;; strings render so far — a Flan value carries no header, so a printer has to
|
|
;; be derived per type at compile time, and the ones that are not derived yet
|
|
;; say so rather than guessing.
|
|
|
|
;;; Code:
|
|
|
|
(require 'subr-x)
|
|
|
|
(defgroup flan-dev nil
|
|
"Talking to a running Flan program."
|
|
:group 'flan
|
|
:prefix "flan-dev-")
|
|
|
|
(defcustom flan-dev-socket-name ".flan-dev.sock"
|
|
"Name of the socket `flan dev' listens on, looked for up from the buffer."
|
|
:type 'string)
|
|
|
|
(defcustom flan-dev-echo-result t
|
|
"Whether a successful evaluation reports in the echo area."
|
|
:type 'boolean)
|
|
|
|
(defcustom flan-dev-output-buffer "*flan-output*"
|
|
"Buffer the running program's own output is appended to."
|
|
:type 'string)
|
|
|
|
(defvar flan-dev--connection nil
|
|
"The open connection, or nil.")
|
|
|
|
(defvar flan-dev--socket nil
|
|
"Path of the socket `flan-dev--connection' is connected to.")
|
|
|
|
;;; Wire
|
|
|
|
;; Framing is a decimal byte count, a newline, then that many bytes. A message
|
|
;; carries Flan source, which contains newlines, so a line-oriented protocol
|
|
;; would need an escape layer that this does not. Lengths are in *bytes*, so
|
|
;; every measurement goes through `string-bytes' and the process is raw-text —
|
|
;; a multibyte identifier would otherwise put the reply stream out of step by
|
|
;; exactly as many bytes as the payload has non-ASCII characters.
|
|
|
|
(defun flan-dev--send (proc form)
|
|
"Send FORM to PROC as one framed message."
|
|
(let* ((payload (encode-coding-string (prin1-to-string form) 'utf-8 t)))
|
|
(process-send-string proc (format "%d\n%s" (length payload) payload))))
|
|
|
|
(defun flan-dev--read-reply (proc)
|
|
"Block until PROC sends one complete framed message, and read it."
|
|
(with-current-buffer (process-buffer proc)
|
|
(let ((deadline (+ (float-time) 30)))
|
|
;; The header first: digits up to a newline.
|
|
(while (and (not (save-excursion (goto-char (point-min))
|
|
(re-search-forward "\\`\\([0-9]+\\)\n" nil t)))
|
|
(< (float-time) deadline))
|
|
(accept-process-output proc 0.05))
|
|
(goto-char (point-min))
|
|
(unless (re-search-forward "\\`\\([0-9]+\\)\n" nil t)
|
|
(error "flan dev: no reply"))
|
|
(let* ((n (string-to-number (match-string 1)))
|
|
(body-start (point)))
|
|
(while (and (< (- (position-bytes (point-max)) (position-bytes body-start)) n)
|
|
(< (float-time) deadline))
|
|
(accept-process-output proc 0.05))
|
|
(let* ((end (byte-to-position (+ (position-bytes body-start) n)))
|
|
(text (decode-coding-string
|
|
(encode-coding-string (buffer-substring-no-properties
|
|
body-start end)
|
|
'utf-8 t)
|
|
'utf-8))
|
|
(form (car (read-from-string text))))
|
|
(delete-region (point-min) end)
|
|
form)))))
|
|
|
|
(defun flan-dev--append-output (text)
|
|
"Append TEXT, the running program's own output, to its buffer."
|
|
(when (and text (> (length text) 0))
|
|
(with-current-buffer (get-buffer-create flan-dev-output-buffer)
|
|
(let ((at-end (= (point) (point-max))))
|
|
(save-excursion
|
|
(goto-char (point-max))
|
|
(insert text))
|
|
;; Follow the tail only for someone who was already at it; a reader
|
|
;; scrolled back is reading something.
|
|
(when at-end (goto-char (point-max)))))))
|
|
|
|
(defun flan-dev--request (form)
|
|
"Send FORM to the connected program and return its reply."
|
|
(let* ((proc (flan-dev--live-connection))
|
|
(reply (progn (flan-dev--send proc form)
|
|
(flan-dev--read-reply proc))))
|
|
;; Whatever the program printed since the last reply rides along with this
|
|
;; one, so the output an evaluation itself caused arrives with its result.
|
|
(flan-dev--append-output (plist-get reply :output))
|
|
reply))
|
|
|
|
;;; Connection
|
|
|
|
(defun flan-dev--find-socket ()
|
|
"Find the daemon's socket by walking up from the current buffer."
|
|
(let ((dir (locate-dominating-file
|
|
(or buffer-file-name default-directory)
|
|
flan-dev-socket-name)))
|
|
(and dir (expand-file-name flan-dev-socket-name dir))))
|
|
|
|
(defun flan-dev--live-connection ()
|
|
"The open connection, or signal an error saying how to get one."
|
|
(unless (and flan-dev--connection
|
|
(process-live-p flan-dev--connection))
|
|
(error "Not connected: M-x flan-connect, or start `flan dev program.flan'"))
|
|
flan-dev--connection)
|
|
|
|
;;;###autoload
|
|
(defun flan-connect (&optional socket)
|
|
"Connect to a `flan dev' daemon listening on SOCKET.
|
|
With no argument, look for `flan-dev-socket-name' up from this buffer."
|
|
(interactive
|
|
(list (or (flan-dev--find-socket)
|
|
(read-file-name "flan dev socket: "))))
|
|
(unless socket (user-error "No %s found above this buffer" flan-dev-socket-name))
|
|
(when (process-live-p flan-dev--connection)
|
|
(delete-process flan-dev--connection))
|
|
(let ((buf (get-buffer-create " *flan-dev*")))
|
|
(with-current-buffer buf (erase-buffer) (set-buffer-multibyte nil))
|
|
(setq flan-dev--connection
|
|
(make-network-process
|
|
:name "flan-dev" :buffer buf :family 'local :service socket
|
|
:coding 'binary :noquery t))
|
|
(setq flan-dev--socket socket))
|
|
(let ((r (flan-dev--request '(:op "describe"))))
|
|
(message "flan dev: connected to %s (%d functions, %d globals)"
|
|
(abbreviate-file-name socket)
|
|
(length (plist-get r :fns)) (length (plist-get r :globals))))
|
|
flan-dev--connection)
|
|
|
|
(defun flan-disconnect ()
|
|
"Close the connection, which also ends the daemon and its program."
|
|
(interactive)
|
|
(when (process-live-p flan-dev--connection)
|
|
(ignore-errors (flan-dev--request '(:op "close")))
|
|
(delete-process flan-dev--connection))
|
|
(setq flan-dev--connection nil)
|
|
(message "flan dev: disconnected"))
|
|
|
|
;;;###autoload
|
|
(defun flan-show-output ()
|
|
"Show the running program's output, after collecting anything pending."
|
|
(interactive)
|
|
(ignore-errors (flan-dev--request '(:op "describe")))
|
|
(display-buffer (get-buffer-create flan-dev-output-buffer)))
|
|
|
|
(defun flan-describe ()
|
|
"Report what the running program currently defines."
|
|
(interactive)
|
|
(let ((r (flan-dev--request '(:op "describe"))))
|
|
(message "flan dev: %s, %d functions, %d globals"
|
|
(if (plist-get r :alive) "running" "exited")
|
|
(length (plist-get r :fns)) (length (plist-get r :globals)))))
|
|
|
|
;;; Evaluating
|
|
|
|
(defun flan-dev--report (reply what)
|
|
"Report REPLY, describing WHAT was sent."
|
|
(if (equal (plist-get reply :status) "ok")
|
|
(let ((fns (plist-get reply :fns))
|
|
(names (plist-get reply :names))
|
|
(note (plist-get reply :note))
|
|
(value (plist-get reply :value)))
|
|
(when flan-dev-echo-result
|
|
(if value
|
|
;; An expression's value, rendered inside the running program —
|
|
;; nothing was marshalled back, because nothing could be.
|
|
(message "=> %s" value)
|
|
(if note
|
|
;; The daemon accepted it and had nothing to send. Say so rather
|
|
;; than claiming an install that did not happen.
|
|
(message "%s: %s" (if names (string-join names ", ") what) note)
|
|
(message "%s installed in %.0fms"
|
|
(if fns (string-join fns ", ")
|
|
(if names (string-join names ", ") what))
|
|
(or (plist-get reply :ms) 0))))))
|
|
;; The daemon reports where, so put point there when it is this buffer.
|
|
(let ((loc (plist-get reply :loc))
|
|
(msg (plist-get reply :message)))
|
|
(when (and loc (string-match "\\`\\(.*\\):\\([0-9]+\\):\\([0-9]+\\)\\'" loc))
|
|
(let ((file (match-string 1 loc))
|
|
(line (string-to-number (match-string 2 loc)))
|
|
(col (string-to-number (match-string 3 loc))))
|
|
(when (and buffer-file-name (file-equal-p file buffer-file-name))
|
|
(goto-char (point-min))
|
|
(forward-line (1- line))
|
|
(forward-char (max 0 (1- col))))))
|
|
(user-error "flan: %s" (or msg "rejected")))))
|
|
|
|
(defun flan-dev--eval (code what)
|
|
"Send CODE to the running program. WHAT names it for the echo area."
|
|
(flan-dev--report
|
|
(flan-dev--request
|
|
;; buffer-file-name so an error points at the file being edited rather than
|
|
;; at the daemon's placeholder.
|
|
(list :op "eval" :code code :file (or buffer-file-name "<buffer>")))
|
|
what))
|
|
|
|
(defun flan-dev--defun-at-point ()
|
|
"The text of the top-level form containing or preceding point."
|
|
(save-excursion
|
|
(end-of-defun)
|
|
(let ((end (point)))
|
|
(beginning-of-defun)
|
|
(buffer-substring-no-properties (point) end))))
|
|
|
|
;;;###autoload
|
|
(defun flan-eval-defun ()
|
|
"Recompile the top-level form at point and install it in the running program."
|
|
(interactive)
|
|
(flan-dev--eval (flan-dev--defun-at-point) "form"))
|
|
|
|
;;;###autoload
|
|
(defun flan-eval-buffer ()
|
|
"Recompile every top-level form in this buffer and install them together.
|
|
One module, not one per form: a var and the function that uses it have to
|
|
arrive in the same load or the first refers to storage that does not exist."
|
|
(interactive)
|
|
(flan-dev--eval (buffer-substring-no-properties (point-min) (point-max))
|
|
(buffer-name)))
|
|
|
|
;;;###autoload
|
|
(defun flan-eval-last-sexp ()
|
|
"Evaluate the expression before point in the running program and show it."
|
|
(interactive)
|
|
(let ((code (buffer-substring-no-properties
|
|
(save-excursion (backward-sexp) (point))
|
|
(point))))
|
|
(flan-dev--report
|
|
(flan-dev--request
|
|
(list :op "eval-expr" :code code :file (or buffer-file-name "<buffer>")))
|
|
"expression")))
|
|
|
|
;;;###autoload
|
|
(defun flan-eval-region (start end)
|
|
"Recompile the top-level forms between START and END."
|
|
(interactive "r")
|
|
(flan-dev--eval (buffer-substring-no-properties start end) "region"))
|
|
|
|
(provide 'flan-dev)
|
|
;;; flan-dev.el ends here
|