291 lines
14 KiB
EmacsLisp
291 lines
14 KiB
EmacsLisp
;;; 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
|