;;; test-flan-watch.el --- Ghost text, from a buffer and a fixture table  -*- lexical-binding: t; -*-

;; Loaded by test-flan-cider.el, which runs under `dune test', for the reason
;; test-flan-mode.el gives: `emacs/*.el' is already a dependency of that
;; stanza, so a file here needs no build change to be run.
;;
;; Nothing here needs a daemon.  Ghost text is a function from *a table of rows*
;; and *the text in a buffer* to *overlays*, and both halves are fixtures: the
;; rows are what a watch reply carries, and the buffer is Flan source.  The
;; interesting failures are all on that side — a call site inside a string taken
;; for code, a name the runtime clipped no longer matching the site that wrote
;; it, an overlay left behind from the last repaint.
;;
;; The one case that is not about text is the subscription: the watch buffer
;; used to *be* the subscription, and ghost text is the second consumer that
;; made that wrong.  Closing one must leave the other running.

;;; Code:

(require 'flan-mode)
(require 'flan-watch)

(declare-function test-flan--check "test-flan-cider" (name ok))

(defun test-flan-watch--buffer (text)
  "A live `flan-mode' buffer holding TEXT, shown in a window.

Shown because `flan-watch--ghost-paint' only scans displayed buffers, which is
what bounds its cost; a `with-temp-buffer' would be scanned by nothing."
  (let ((buf (get-buffer-create "test-flan-watch.flan")))
    (with-current-buffer buf
      (let ((inhibit-read-only t))
        (erase-buffer)
        (insert text))
      (flan-mode))
    (set-window-buffer (selected-window) buf)
    buf))

(defun test-flan-watch--starts ()
  "Where the overlays sit, in buffer order."
  (sort (mapcar #'overlay-start flan-watch--ghost-overlays) #'<))

(defun test-flan-watch--strings ()
  "What the overlays say, in buffer order."
  (mapcar (lambda (ov) (substring-no-properties (overlay-get ov 'after-string)))
          (sort (copy-sequence flan-watch--ghost-overlays)
                (lambda (a b) (< (overlay-start a) (overlay-start b))))))

;; --- Finding the call site ------------------------------------------------
;;
;; The anchor is searched for rather than reported, because the table carries a
;; name and no location.  A call inside a string is the case that makes the
;; syntax check earn its place: it is text that looks exactly like code.

(let ((buf (test-flan-watch--buffer
            (concat "(defn step [] i64\n"
                    "  (watch-i64 \"ticks\" ticks)\n"
                    "  (watch-f64 \"hp\" hp)\n"
                    "  (println \"(watch-i64 \\\"fake\\\" x)\")\n"
                    "  (watch \"hp\" hp))\n"))))
  (with-current-buffer buf
    (let ((sites (flan-watch--ghost-sites)))
      (test-flan--check
       "every watch call in the buffer is found, by the name it writes"
       (equal (mapcar #'car sites) '("ticks" "hp" "hp")))
      (test-flan--check
       "and a call written inside a string is not one of them"
       (not (member "fake" (mapcar #'car sites)))))))

;; --- Every head the default regexp claims to cover ------------------------
;;
;; `flan-watch-ghost-call-regexp' allows *any number* of hyphenated segments,
;; and the accumulator is why.  With one optional segment — the `?\=' this
;; default used to have — `watch-num-i64' matched as far as `watch-num', then
;; required whitespace, found `-i64', and backtracked to failure.  The failure
;; is silent and looks like nothing: the row is in the watch buffer as usual
;; and the call site simply never gets an inline value.  So the two-segment
;; heads are pinned here beside the one-segment ones, or the next widening of
;; this default has nothing to fail against.

(let ((buf (test-flan-watch--buffer
            (concat "(defn step [] i64\n"
                    "  (watch \"bare\" x)\n"
                    "  (watch-i64 \"ticks\" ticks)\n"
                    "  (watch-f64 \"hp\" hp)\n"
                    "  (watch-str \"label\" label)\n"
                    "  (watch-num-i64 \"cell\" (at grid i))\n"
                    "  (watch-num-f64 \"dt\" dt))\n"))))
  (with-current-buffer buf
    (let ((sites (flan-watch--ghost-sites)))
      (test-flan--check
       "a two-segment head is a site: the accumulator gets inline text too"
       (equal (assoc "cell" sites)
              (cons "cell" (save-excursion (goto-char (point-min))
                                           (line-end-position 6)))))
      (test-flan--check
       "and every head the default documents is found, in buffer order"
       (equal (mapcar #'car sites)
              '("bare" "ticks" "hp" "label" "cell" "dt"))))))

;; --- Matching a row to a site ---------------------------------------------
;;
;; The runtime holds 31 bytes of a name, so a longer one in the source can
;; never match a row exactly.  The prefix fallback is guarded on the row being
;; a full 31 bytes, or a short name would claim any site that starts with it.

(let ((long (make-string 40 ?a)))
  (test-flan--check
   "a name the runtime clipped at 31 bytes still matches the site that wrote it"
   (equal (flan-watch--ghost-row long (list (cons (make-string 31 ?a) "9")))
          (cons (make-string 31 ?a) "9")))
  (test-flan--check
   "and a row short enough not to have been clipped claims only its own site"
   (null (flan-watch--ghost-row "hpx" '(("hp" . "1"))))))

;; --- What an overlay says -------------------------------------------------

(test-flan--check "a running value is just the value"
                  (equal (substring-no-properties
                          (flan-watch--ghost-text "42" 1 nil))
                         "  => 42"))
(test-flan--check
 "two sites of one name each say so, because the table has one slot"
 (string-match-p "one slot, 2 sites"
                 (flan-watch--ghost-text "42" 2 nil)))
(test-flan--check
 "and one site says nothing about sites"
 (not (string-match-p "sites" (flan-watch--ghost-text "42" 1 nil))))
(test-flan--check
 "a stopped program's value says it is the last frame's"
 (string-match-p "last frame" (flan-watch--ghost-text "42" 1 t)))
(test-flan--check
 "and is drawn in the face that is not the running one"
 (eq (get-text-property 0 'face (flan-watch--ghost-text "42" 1 t))
     'flan-watch-ghost-stale-face))

;; --- Painting -------------------------------------------------------------

(let ((buf (test-flan-watch--buffer
            (concat "(watch-i64 \"ticks\" ticks)\n"
                    "(watch-i64 \"ticks\" ticks)\n"
                    "(watch-i64 \"gone\" g)\n")))
      (flan-watch--consumers '(ghost))
      (flan--stopped nil))
  (flan-watch--ghost-paint '(("ticks" . "42")) nil)
  (test-flan--check
   "a site whose name is in the table gets an overlay, and one that is not does not"
   (equal (test-flan-watch--strings)
          '("  => 42   one slot, 2 sites" "  => 42   one slot, 2 sites")))
  (test-flan--check
   "each one sits at the end of its own call's line"
   (equal (test-flan-watch--starts)
          (with-current-buffer buf
            (save-excursion (goto-char (point-min))
                            (list (line-end-position 1) (line-end-position 2))))))

  ;; The one case worth annotating a site with no row: the value exists and was
  ;; dropped.  The watch buffer's overflow line says the same thing without
  ;; being able to say which name it happened to.
  (flan-watch--ghost-paint '(("ticks" . "42")) t)
  (test-flan--check
   "with the table full, the site that found no slot is told so rather than left blank"
   (equal (nth 2 (test-flan-watch--strings))
          "  => no slot: the table is full"))

  (setq flan--stopped "BoundsError")
  (flan-watch--ghost-paint '(("ticks" . "42")) nil)
  (test-flan--check
   "stopping the program marks every overlay, not the buffer's modeline only"
   (equal (test-flan-watch--strings)
          '("  => 42   one slot, 2 sites   last frame"
            "  => 42   one slot, 2 sites   last frame")))
  (setq flan--stopped nil)

  ;; The whole answer to invalidating an overlay whose line moved: no overlay
  ;; outlives a repaint, so there is nothing to invalidate.
  (with-current-buffer buf
    (let ((inhibit-read-only t))
      (save-excursion (goto-char (point-min)) (insert "\n\n"))))
  (flan-watch--ghost-paint '(("ticks" . "42")) nil)
  (test-flan--check
   "editing the buffer strands nothing: a repaint replaces every overlay"
   (equal (test-flan-watch--starts)
          (with-current-buffer buf
            (save-excursion (goto-char (point-min))
                            (list (line-end-position 3) (line-end-position 4))))))

  ;; A refusal clears them.  Inline there is nowhere to print an error, so a
  ;; stale number beside live code would be the whole picture and it would lie.
  (flan-watch--absorb '(:status "error" :message "no"))
  (test-flan--check "a refused reply takes the overlays with it"
                    (null flan-watch--ghost-overlays))
  (test-flan--check "and leaves none behind in the buffer"
                    (with-current-buffer buf
                      (null (overlays-in (point-min) (point-max))))))

;; --- The subscription -----------------------------------------------------
;;
;; The buffer used to be the subscription, so killing it disarmed the table.
;; With two consumers that is wrong: closing one must leave the other armed,
;; and only the last one out turns the lights off.

(let ((flan-watch--consumers '(buffer ghost))
      (torn nil))
  (cl-letf (((symbol-function 'flan-watch-stop) (lambda () (setq torn t))))
    (flan-watch--drop 'buffer)
    (test-flan--check "closing the watch buffer leaves ghost text armed"
                      (and (equal flan-watch--consumers '(ghost)) (not torn)))
    (flan-watch--drop 'ghost)
    (test-flan--check "and the last consumer out disarms the table"
                      (and (null flan-watch--consumers) torn))))

;; --- Pushes and replies on one connection ---------------------------------
;;
;; The daemon writes two kinds of frame: replies, and pushes it sends without
;; being asked — output as it is printed, the watch table while it is armed.
;; The filter handles a push as it arrives and queues a reply for whoever is
;; waiting.  Frames are written into a pipe process's buffer by hand, split
;; mid-frame the way a socket may deliver them, so what is claimed is the
;; reader and not the daemon.

(defun test-flan-watch--frame (form)
  "FORM framed as the daemon frames it."
  (let ((payload (encode-coding-string (prin1-to-string form) 'utf-8 t)))
    (format "%d\n%s" (length payload) payload)))

(let* ((buf (generate-new-buffer " *flan-push-test*"))
       (proc (make-pipe-process :name "flan-push-test" :buffer buf
                                :noquery t))
       (painted nil)
       (appended nil)
       (flan-watch--consumers '(ghost)))
  (with-current-buffer buf (set-buffer-multibyte nil))
  (unwind-protect
      (cl-letf (((symbol-function 'flan-watch--absorb)
                 (lambda (r) (push r painted)))
                ((symbol-function 'flan--append-output)
                 (lambda (text) (push text appended))))
        (let ((flan-push-functions '(flan-watch--on-push))
              (stream
               (concat
                (test-flan-watch--frame '(:push "output" :status "ok"
                                                :output "héllo\n"))
                (test-flan-watch--frame '(:status "ok" :value "42"))
                (test-flan-watch--frame '(:push "watch" :status "ok"
                                                :watch (("ticks" "7"))
                                                :overflow nil)))))
          ;; In three pieces, the first ending inside the first frame's body.
          (flan--filter proc (substring stream 0 12))
          (test-flan--check "a push is not handled before all of it has arrived"
                            (null appended))
          (flan--filter proc (substring stream 12 40))
          (flan--filter proc (substring stream 40))
          (test-flan--check "an output push reaches the output as it arrives"
                            (equal appended
                                   (list (decode-coding-string
                                          (encode-coding-string "héllo\n" 'utf-8)
                                          'utf-8))))
          (test-flan--check "a watch push behind a reply is painted without waiting for the reply to be read"
                            (equal (plist-get (car painted) :watch)
                                   '(("ticks" "7"))))
          (test-flan--check "and the reply is kept for the request that asked"
                            (equal (flan--take-reply proc)
                                   '(:status "ok" :value "42")))
          (test-flan--check "and taken once"
                            (null (flan--take-reply proc)))
          (let ((flan-watch--consumers nil))
            (flan--filter proc (test-flan-watch--frame
                                '(:push "watch" :status "ok" :watch nil)))
            (test-flan--check "a watch push with nothing watching paints nothing"
                              (= 1 (length painted))))))
    (delete-process proc)
    (kill-buffer buf)))

;; The daemon's buffer keeps `flan-output-maximum-lines' and loses the oldest.
(let ((flan-daemon-buffer " *flan-trim-test*")
      (flan-output-maximum-lines 10))
  (unwind-protect
      (progn
        (dotimes (i 30) (flan--append-output (format "line %d\n" i)))
        (with-current-buffer flan-daemon-buffer
          (test-flan--check "the daemon's buffer is kept to its line limit"
                            (<= (count-lines (point-min) (point-max)) 10))
          (test-flan--check "and keeps the newest lines"
                            (and (string-match-p "line 29" (buffer-string))
                                 (not (string-match-p "line 0\n" (buffer-string)))))))
    (kill-buffer flan-daemon-buffer)))

(provide 'test-flan-watch)
;;; test-flan-watch.el ends here