;;; test-flan-dev.el --- Drive the client against a running program  -*- lexical-binding: t; -*-

;; Run as:  emacs -Q --batch -L emacs -l emacs/test-flan-dev.el -- <socket> <flan-file>
;;
;; This is the client half of test_dev.ml.  The OCaml test proves the daemon
;; answers correctly; this proves the elisp actually talks to it — the framing,
;; the reply reader, and C-c C-c picking the right form out of a buffer.  A
;; protocol bug that only shows up under Emacs' coding systems would pass the
;; OCaml test and fail here, which is the whole reason it exists.

;;; Code:

(require 'flan-mode)
(require 'flan-dev)
(require 'flan-repl)

(defvar test-flan--failures 0)

(defmacro test-flan--said (&rest body)
  "Run BODY and return the last thing it put in the echo area.
`current-message' is nil under --batch, so the echo area is watched where it
is written instead — the real `message' call the real command makes."
  `(let* ((said nil)
          (probe (lambda (fmt &rest args)
                   (when fmt (setq said (apply #'format fmt args))))))
     (advice-add 'message :before probe)
     (unwind-protect (progn ,@body)
       (advice-remove 'message probe))
     said))

(defun test-flan--check (name ok)
  (if ok (message "  ok   %s" name)
    (setq test-flan--failures (1+ test-flan--failures))
    (message "  FAIL %s" name)))

(let* ((args (cdr (member "--" command-line-args)))
       (socket (nth 0 args))
       (file   (nth 1 args)))
  (find-file file)
  ;; The copy comes out of a build directory, so it may arrive read-only.
  ;; Set the flag directly: `read-only-mode' asks about the file on disk, and
  ;; a question in a batch run is a hang waiting to happen.
  (setq buffer-read-only nil)
  (test-flan--check "flan-mode is on for a .flan file" (eq major-mode 'flan-mode))

  (test-flan--check "the modeline says so before connecting"
                    (and (eq (flan-dev-state) 'off)
                         (string-match-p "off" (flan-dev-mode-line))))

  (flan-connect socket)
  (test-flan--check "connected" (process-live-p flan-dev--connection))
  (test-flan--check "the modeline says a program is there"
                    (and (eq (flan-dev-state) 'live)
                         (string-match-p "live" (flan-dev-mode-line))))
  (test-flan--check "and says nothing in a buffer that is not Flan's"
                    (with-temp-buffer (null (flan-dev-mode-line))))

  ;; A daemon restarted while Emacs was not looking is the ordinary case.  The
  ;; socket outlives this connection, so dropping the process and asking again
  ;; is the same situation the client meets after a restart, and it must come
  ;; back rather than fail.
  (delete-process flan-dev--connection)
  (test-flan--check "a dead connection reads as lost, not as never-connected"
                    (and (eq (flan-dev-state) 'lost)
                         (string-match-p "lost" (flan-dev-mode-line))))
  (let ((r (flan-dev--request '(:op "describe"))))
    (test-flan--check "the next request reconnects on its own"
                      (and (process-live-p flan-dev--connection)
                           (member "step" (plist-get r :fns)))))

  ;; But a socket nobody is listening on is refused by name, rather than
  ;; retried forever or reported as some other failure.
  (let ((flan-dev--connection nil)
        (flan-dev--socket "/nonexistent/flan-dev-not-here.sock")
        (raised nil))
    (condition-case err (flan-dev--request '(:op "describe"))
      (error (setq raised (error-message-string err))))
    (test-flan--check "a socket that is gone is refused by name"
                      (and raised
                           (string-match-p "flan-dev-not-here.sock" raised)
                           (string-match-p "nothing is listening" raised))))

  (let ((r (flan-dev--request '(:op "describe"))))
    (test-flan--check "describe lists the program's functions"
                      (member "step" (plist-get r :fns)))
    (test-flan--check "describe lists the program's globals"
                      (member "ticks" (plist-get r :globals))))

  ;; C-c C-c on the form at point: put point inside `step' and send it.  The
  ;; text comes from the buffer, so this exercises `beginning-of-defun' against
  ;; Flan's own syntax table as much as it does the wire.
  (goto-char (point-min))
  (search-forward "(defn step")
  (goto-char (match-beginning 0))
  (save-excursion
    (search-forward "(+ ticks 1)")
    (replace-match "(+ ticks 41)"))
  (let ((form (flan-dev--defun-at-point)))
    (test-flan--check "the form at point is the defn"
                      (and (string-prefix-p "(defn step" (string-trim form))
                           (string-match-p "41" form))))
  (flan-eval-defun)

  ;; And an error: the daemon answers with a location, the client raises.
  (let ((raised nil))
    (condition-case err
        (flan-dev--eval "(defn step [] i64 nonsense)" "form")
      (user-error (setq raised (error-message-string err))))
    (test-flan--check "a form that does not check is reported"
                      (and raised (string-match-p "unknown name" raised))))

  ;; The :loc column is a *byte* offset — lib/reader.ml walks the source a byte
  ;; at a time — and Emacs counts characters.  Same rule as the framing, a
  ;; different place to get it wrong, and it shows up only for someone whose
  ;; comments or identifiers are not ASCII.
  (with-temp-buffer
    (insert ";; héllo\n(defn wörld [] i64 nonsense)\n")
    (let ((want (save-excursion
                  (goto-char (point-min))
                  (search-forward "nonsense")
                  (match-beginning 0)))
          (eol (save-excursion (goto-char (point-min)) (line-end-position))))
      (test-flan--check "a byte column lands on the right character"
                        (= (flan-dev--position
                            2 (1+ (string-bytes "(defn wörld [] i64 ")))
                           want))
      (test-flan--check "a column past the end of a line is clamped to it"
                        (= (flan-dev--position 1 500) eol))))

  ;; A rejected form is marked where it is, not only in the echo area.  The
  ;; daemon numbers lines from the start of what it was sent, so a form taken
  ;; from the middle of a buffer only lands on the right line because the
  ;; client pads it back into place before sending.
  (goto-char (point-min))
  (search-forward "(defn step")
  (goto-char (match-beginning 0))
  (let ((defn-line (line-number-at-pos)))
    (save-excursion
      (search-forward "(+ ticks 41)")
      (replace-match "(+ ticks nonsense)"))
    (ignore-errors (flan-eval-defun))
    (let ((ovs (seq-filter (lambda (o) (overlay-get o 'flan-dev-error))
                           (overlays-in (point-min) (point-max)))))
      (test-flan--check "a rejected form gets exactly one error overlay"
                        (= 1 (length ovs)))
      (test-flan--check "the overlay is at the form, not at line 1"
                        (and ovs (>= (line-number-at-pos (overlay-start (car ovs)))
                                     defn-line)))
      (test-flan--check "the overlay carries the daemon's reason"
                        (and ovs
                             (string-match-p
                              "unknown name"
                              (or (overlay-get (car ovs) 'help-echo) ""))))
      (test-flan--check "and shows it beside the code"
                        (and ovs
                             (string-match-p
                              "unknown name"
                              (or (overlay-get (car ovs) 'after-string) "")))))
    ;; ...and it goes away when the next evaluation is accepted.  A marker left
    ;; behind after a fix is a lie about the running program.  Point moved to
    ;; the error, which is the point of all this, so start the search over.
    (goto-char (point-min))
    (search-forward "(+ ticks nonsense)")
    (replace-match "(+ ticks 41)")
    (search-backward "(defn step")
    ;; A silent success is indistinguishable from a silent failure, so an
    ;; accepted evaluation says what landed in the running program and what it
    ;; cost.  The name comes from the *reply*: the daemon is the one that knows
    ;; which names it installed.
    (let ((said (test-flan--said (flan-eval-defun))))
      (test-flan--check "an accepted evaluation clears it"
                        (null (seq-filter (lambda (o) (overlay-get o 'flan-dev-error))
                                          (overlays-in (point-min) (point-max)))))
      (test-flan--check "and says which name landed"
                        (and said (string-match-p "\\_<step\\_>" said)))
      (test-flan--check "and how long it took"
                        (and said (string-match-p "[0-9]+ ms" said)))))

  ;; A declaration the program already has installs nothing, and must say so
  ;; rather than reporting a time for a build that did not happen.
  (let ((said (test-flan--said
               (flan-dev--eval "(defvar ticks i64)" "form"))))
    (test-flan--check "an evaluation with nothing to install says so"
                      (and said (string-match-p "nothing to install" said)
                           (not (string-match-p "installed" said)))))

  ;; Many names are counted and sampled.  An echo area truncated in the middle
  ;; of the tenth name says neither how many there were nor which.
  (test-flan--check "a long list of names is counted, not cut off"
                    (equal (flan-dev--names-phrase
                            '("a" "b" "c" "d" "e" "f") "fallback")
                           "6 names (a, b, c, d, …)"))
  (test-flan--check "a short one is just named"
                    (equal (flan-dev--names-phrase '("a" "b") "fallback") "a, b"))

  ;; The session is not poisoned by that: a good form still lands.
  (flan-dev--eval "(defn step [] i64 (set ticks (+ ticks 100)) ticks)" "form")

  ;; The program's own output arrives on replies and lands in its buffer, so
  ;; a long-running program is not writing into a terminal nobody is watching.
  (flan-dev--eval "(defn step [] i64 (do (print-line \"HELLO\") ticks))" "form")
  (let ((seen nil) (deadline (+ (float-time) 10)))
    (while (and (not seen) (< (float-time) deadline))
      (ignore-errors (flan-dev--request '(:op "describe")))
      (setq seen (with-current-buffer (get-buffer-create flan-dev-output-buffer)
                   (string-match-p "HELLO" (buffer-string)))))
    (test-flan--check "the program's output reaches its buffer" seen))

  ;; The REPL buffer: typed input goes through the same eval-expr request, and
  ;; the value lands at the prompt while the program's own output goes to
  ;; *flan-output*. Conflating those two is the bug worth testing for.
  (test-flan--check "an incomplete form is not sent"
                    (not (flan-repl--complete-p "(+ 1")))
  (test-flan--check "a whole form is sent" (flan-repl--complete-p "(+ 1 2)"))
  (test-flan--check "a paren in a string does not count"
                    (not (flan-repl--complete-p "(f \"(\"")))
  (flan-repl)
  (with-current-buffer flan-repl-buffer
    (goto-char (point-max))
    (insert "(+ 20 3)")
    (flan-repl-return)
    (let ((deadline (+ (float-time) 15)))
      (while (and (not (string-match-p "23" (buffer-string)))
                  (< (float-time) deadline))
        (accept-process-output nil 0.05)))
    (test-flan--check "the REPL shows a value"
                      (string-match-p "23" (buffer-string)))
    (goto-char (point-max))
    (insert "no-such-thing")
    (flan-repl-return)
    (let ((deadline (+ (float-time) 15)))
      (while (and (not (string-match-p "unknown name" (buffer-string)))
                  (< (float-time) deadline))
        (accept-process-output nil 0.05)))
    (test-flan--check "the REPL shows an error"
                      (string-match-p "unknown name" (buffer-string)))
    ;; A value and the program's output travel by different routes: the value
    ;; is the result of the request, the output rides along with the reply.
    ;; Showing them in one place would be convenient and wrong.
    (goto-char (point-max))
    (insert "(print-line \"PRINTED\")")
    (flan-repl-return)
    (let ((deadline (+ (float-time) 15)))
      (while (and (not (with-current-buffer flan-dev-output-buffer
                         (string-match-p "PRINTED" (buffer-string))))
                  (< (float-time) deadline))
        (ignore-errors (flan-dev--request '(:op "describe")))
        (accept-process-output nil 0.05)))
    (test-flan--check "printed text goes to the output buffer"
                      (with-current-buffer flan-dev-output-buffer
                        (string-match-p "PRINTED" (buffer-string))))
    ;; ...and the prompt got the *value*, which for a call made for its effect
    ;; is Unit. The text it printed is not the value and does not belong here.
    (test-flan--check "and the prompt got the value, not the text"
                      (string-match-p "()" (buffer-string))))

  (flan-disconnect)
  (test-flan--check "disconnected" (not (process-live-p flan-dev--connection)))

  (if (zerop test-flan--failures)
      (message "flan-dev.el: all tests passed")
    (message "\n%d failure(s)" test-flan--failures)
    (kill-emacs 1)))

;;; test-flan-dev.el ends here