;;; 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)
(require 'seq)

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

;;; Where an error is

;; A reply's :loc is "file:line:col", and the column is a *byte* offset into
;; the line: the reader walks the source a byte at a time (lib/reader.ml), and
;; OCaml strings are bytes.  Emacs counts characters, so the same rule the
;; framing has applies here — one non-ASCII character earlier on the line puts
;; the marker as many columns to the right as that character has bytes.  Going
;; through `byte-to-position' from the line's start is the whole fix, and
;; `forward-char' would also have walked into the next line on a column past
;; the end of a short one.

(defun flan-dev--parse-loc (loc)
  "Split LOC, a \"file:line:col\" string, into (FILE LINE COL), or nil."
  (when (and (stringp loc)
             (string-match "\\`\\(.*\\):\\([0-9]+\\):\\([0-9]+\\)\\'" loc))
    (list (match-string 1 loc)
          (string-to-number (match-string 2 loc))
          (string-to-number (match-string 3 loc)))))

(defun flan-dev--position (line col)
  "Position of LINE and byte-column COL in the current buffer."
  (save-excursion
    (goto-char (point-min))
    (forward-line (1- line))
    (let* ((bol (point))
           (eol (line-end-position))
           (want (+ (position-bytes bol) (max 0 (1- col))))
           (p (and (<= want (position-bytes eol)) (byte-to-position want))))
      ;; Clamped rather than trusted: a column past the end of the line is a
      ;; location for something the reader wanted and did not find, and
      ;; overshooting into the next line would point at innocent code.
      (min (or p eol) eol))))

(defun flan-dev--buffer-visiting (file)
  "The live buffer visiting FILE, or nil.
Compared with `file-equal-p', so a symlinked or relative path still matches."
  (seq-find (lambda (b)
              (let ((n (buffer-local-value 'buffer-file-name b)))
                (and n (file-exists-p file) (file-equal-p n file))))
            (buffer-list)))

;;; Error overlays

;; An error is shown where it is rather than only in the echo area, because the
;; echo area is gone the moment you type and the location is the useful half of
;; the message.  It is cleared when the next evaluation of that buffer is
;; accepted: an overlay left behind after a fix is a lie about the program, and
;; a stale one is worse than none.

(defface flan-dev-error-face
  '((t :inherit error :underline (:style wave)))
  "Face for the text an evaluation was rejected at."
  :group 'flan-dev)

(defface flan-dev-error-message-face
  '((t :inherit error :height 0.9))
  "Face for the message shown beside a rejected form."
  :group 'flan-dev)

(defun flan-dev-clear-errors (&optional buffer)
  "Remove Flan error overlays from BUFFER, or from the current buffer."
  (interactive)
  (with-current-buffer (or buffer (current-buffer))
    (remove-overlays (point-min) (point-max) 'flan-dev-error t)))

(defun flan-dev--show-error (loc msg)
  "Mark MSG at LOC, if LOC names a file some buffer is visiting.
Returns non-nil when it put an overlay somewhere."
  (let ((parts (flan-dev--parse-loc loc)))
    (when parts
      (let ((buf (flan-dev--buffer-visiting (nth 0 parts))))
        (when buf
          (with-current-buffer buf
            (flan-dev-clear-errors buf)
            (let* ((beg (flan-dev--position (nth 1 parts) (nth 2 parts)))
                   (end (save-excursion (goto-char beg) (line-end-position)))
                   (ov (make-overlay beg end buf t nil)))
              (overlay-put ov 'flan-dev-error t)
              (overlay-put ov 'face 'flan-dev-error-face)
              (overlay-put ov 'help-echo msg)
              (overlay-put ov 'evaporate nil)
              (overlay-put ov 'priority 100)
              (overlay-put ov 'after-string
                           (propertize (concat "  " msg)
                                       'face 'flan-dev-error-message-face))
              ;; Point goes there too, but only in the buffer being looked at:
              ;; moving point in a buffer nobody is showing is a surprise the
              ;; next time it is visited.
              (when (eq buf (current-buffer)) (goto-char beg))
              t)))))))

;;; 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)))
        ;; Accepted, so whatever the last rejection marked is no longer true.
        (flan-dev-clear-errors)
        (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 mark it there.  This must not itself
    ;; signal: the error the caller is owed is the daemon's, and losing it to a
    ;; bad location would report the wrong thing entirely.
    (let ((loc (plist-get reply :loc))
          (msg (plist-get reply :message)))
      (ignore-errors (flan-dev--show-error loc (or msg "rejected")))
      (user-error "flan: %s%s" (or msg "rejected")
                  (if loc (format " (%s)" loc) "")))))

(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--text (start end)
  "The buffer text from START to END, on the line it is actually written on.

The daemon reads what it is sent starting at line 1, so a form taken from the
middle of a buffer comes back with a location relative to the *snippet* — and
an error overlay drawn from that sits on line 1 of the file, pointing at
whatever happens to be there.  Leading newlines are the whole fix: the reader
skips them, and the line numbers in the reply are then the buffer's own.  The
columns already were, because a top-level form starts at column 1."
  (concat (make-string (1- (line-number-at-pos start)) ?\n)
          (buffer-substring-no-properties start end)))

(defun flan-dev--defun-bounds ()
  "Bounds of the top-level form containing or preceding point, as (START . END)."
  (save-excursion
    (end-of-defun)
    (let ((end (point)))
      (beginning-of-defun)
      (cons (point) end))))

(defun flan-dev--defun-at-point ()
  "The text of the top-level form containing or preceding point."
  (let ((b (flan-dev--defun-bounds)))
    (buffer-substring-no-properties (car b) (cdr b))))

;;;###autoload
(defun flan-eval-defun ()
  "Recompile the top-level form at point and install it in the running program."
  (interactive)
  (let ((b (flan-dev--defun-bounds)))
    (flan-dev--eval (flan-dev--text (car b) (cdr b)) "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 (flan-dev--text start end) "region"))

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