;;; 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