;;; test-flan-cider.el --- The inspector and break buffers, from fixtures  -*- lexical-binding: t; -*-

;; Run as:  emacs -Q --batch -L emacs -l emacs/test-flan-cider.el
;;
;; Nothing here needs a daemon or a running program, and that is deliberate
;; rather than a shortcut.  Both buffers are functions from *a reply's data* to
;; *text with properties on it*, and the interesting failures are all on that
;; side: a struct the reader mis-parses, a shadowed restart drawn as though it
;; could be chosen, a section quietly omitted instead of refused.  Driving it
;; from fixtures tests exactly that, and it tests the cases a live program
;; cannot easily be made to produce — a value past the renderer's depth bound,
;; two restarts with one name, a frame with locals in it at all.
;;
;; The fixtures are not invented.  Every rendered string below is the shape
;; `Session.render' writes, case by case, and the comment on each says which.

;;; Code:

(require 'flan-inspect)

(defvar test-flan--failures 0)
(defvar test-flan--ran 0)

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

(defun test-flan--text (thunk)
  "Run THUNK in a scratch buffer and return what it drew."
  (with-temp-buffer
    (funcall thunk)
    (buffer-substring-no-properties (point-min) (point-max))))

(defun test-flan--caught (thunk)
  "The message of the error THUNK signals, or nil if it does not."
  (condition-case e (progn (funcall thunk) nil)
    (error (error-message-string e))))


;;; The reader

(message "\nreading what the renderer wrote")

;; (V {:x 1.5 :y 0}) — Types.Named, lib/session.ml.
(let ((n (flan-inspect-parse "(V {:x 1.5 :y 0})")))
  (test-flan--check "a struct is a struct" (eq (plist-get n :kind) 'struct))
  (test-flan--check "with its type name" (equal (plist-get n :type) "V"))
  (test-flan--check "and its fields in order"
                    (equal (mapcar #'car (plist-get n :children)) '("x" "y")))
  (test-flan--check "carrying their values"
                    (equal (plist-get (cdr (assoc "x" (plist-get n :children))) :text)
                           "1.5")))

;; The whole of NEXT.md's worked example, nested two deep with a string that
;; has escaped quotes in it and a slice at the end.
(let* ((src "(Blob {:id 7 :name \"sandy \\\"quoted\\\"\" :pos (V {:x 1.5 :y 0}) :tags [ 0 42 0]})")
       (n (flan-inspect-parse src))
       (kids (plist-get n :children)))
  (test-flan--check "every field of a nested struct"
                    (equal (mapcar #'car kids) '("id" "name" "pos" "tags")))
  (test-flan--check "an escaped quote does not end the string early"
                    (equal (plist-get (cdr (assoc "name" kids)) :text)
                           "\"sandy \"quoted\"\""))
  (test-flan--check "a struct inside a struct"
                    (equal (plist-get (cdr (assoc "pos" kids)) :type) "V"))
  (test-flan--check "a slice inside a struct, with its elements"
                    (equal (mapcar #'car (plist-get (cdr (assoc "tags" kids)) :children))
                           '(0 1 2))))

;; [ 0 42 0] — Types.Slice and Types.Array both write this.
(let ((n (flan-inspect-parse "[ 0 42 0]")))
  (test-flan--check "a sequence is a sequence" (eq (plist-get n :kind) 'seq))
  (test-flan--check "indexed from zero"
                    (equal (mapcar #'car (plist-get n :children)) '(0 1 2))))

;; [ [ 0 0] [ 1 ...] ...] — span truncation at both levels, which is what
;; sand's [100 [100 u32]] actually produces.
(let* ((n (flan-inspect-parse "[ [ 0 0] [ 1 ...] ...]"))
       (kids (plist-get n :children)))
  (test-flan--check "a trailing ... is truncation, not an element"
                    (and (= (length kids) 2) (plist-get n :truncated)))
  (test-flan--check "and it is noticed on the inner sequence too"
                    (plist-get (cdr (nth 1 kids)) :truncated)))

;; The renderer's refusals, each of which becomes a leaf here.
(test-flan--check "a pointer is a pointer"
                  (eq (plist-get (flan-inspect-parse "<ptr>") :kind) 'ptr))
(test-flan--check "a type the walk had no structure for"
                  (eq (plist-get (flan-inspect-parse "<Widget>") :kind) 'opaque))
(test-flan--check "the depth bound"
                  (eq (plist-get (flan-inspect-parse "...") :kind) 'trunc))
(test-flan--check "an option"
                  (eq (plist-get (flan-inspect-parse "(some 3)") :kind) 'option))
(test-flan--check "an enum member is an atom, not a field"
                  (eq (plist-get (flan-inspect-parse ":blue") :kind) 'atom))
(test-flan--check "and so is a u64 that fills the range"
                  (equal (plist-get (flan-inspect-parse "18446744073709551615") :text)
                         "18446744073709551615"))

;; A struct with a `...' where a field would be: span truncation *inside* a
;; struct, which is a different position in the grammar from a sequence's.
(let ((n (flan-inspect-parse "(Wide {:a 1 :b 2 ...})")))
  (test-flan--check "a struct's span bound is truncation, not a field"
                    (and (equal (mapcar #'car (plist-get n :children)) '("a" "b"))
                         (plist-get n :truncated))))


;;; Where a field is, said in Flan

(message "\nthe path is an expression")

(test-flan--check "a field is a field accessor"
                  (equal (flan-inspect-step-expr "b" '(:field "pos")) "(.pos b)"))
(test-flan--check "an element is `at'"
                  (equal (flan-inspect-step-expr "(.tags b)" '(:index 2))
                         "(at (.tags b) 2)"))
(test-flan--check "and they compose, which is the whole trick"
                  (equal (flan-inspect-step-expr
                          (flan-inspect-step-expr "b" '(:field "pos")) '(:field "x"))
                         "(.x (.pos b))"))


;;; Refusals, by name, with the reason

(message "\nwhat cannot be entered says so")

(dolist (case '(("<ptr>" "pointer") ("..." "depth bound") ("7" "atom")
                ("(some 3)" "accessor form") ("<Widget>" "no structure")))
  (let ((why (flan-inspect-refusal (flan-inspect-parse (car case)))))
    (test-flan--check (format "%s refuses, naming %s" (car case) (cadr case))
                      (and why (string-match-p (regexp-quote (cadr case)) why)))))

(test-flan--check "a struct with fields does not refuse"
                  (null (flan-inspect-refusal (flan-inspect-parse "(V {:x 1 :y 2})"))))


;;; The inspector buffer

(message "\nthe inspector buffer")

(defun test-flan--inspect (expr rendered)
  "Draw EXPR's RENDERED value in a temp buffer and return it, live."
  (let ((flan-inspect-request-function
         (lambda (_) (list :status "ok" :value rendered)))
        (flan-inspect-buffer " *test-inspect*"))
    (when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
    (save-window-excursion (flan-inspect--show expr nil))))

(let* ((buf (test-flan--inspect
             "b" "(Blob {:id 7 :name \"sandy\" :pos (V {:x 1.5 :y 0})})"))
       (text (with-current-buffer buf (buffer-string))))
  (test-flan--check "the expression is at the top" (string-match-p "\\`b\n" text))
  (test-flan--check "and the type under it" (string-match-p "a Blob" text))
  (test-flan--check "the fields are listed" (string-match-p ":id.*7" text))
  (test-flan--check "a nested struct is summarised, not expanded"
                    (string-match-p ":pos +(V … 2 fields)" text))
  (test-flan--check "and the keys are shown" (string-match-p "RET inspect" text))
  ;; Every field line carries the step that reaches it.
  (with-current-buffer buf
    (goto-char (point-min))
    (flan-inspect-next)
    (test-flan--check "TAB lands on the first field"
                      (equal (get-text-property (point) 'flan-inspect-step)
                             '(:field "id")))
    (flan-inspect-next)
    (flan-inspect-next)
    (test-flan--check "and walks to the third"
                      (equal (get-text-property (point) 'flan-inspect-step)
                             '(:field "pos")))))

;; Going in sends a *different expression*, which is the entire adaptation.
(let ((asked nil))
  (let ((flan-inspect-request-function
         (lambda (form)
           (push (plist-get form :code) asked)
           (list :status "ok"
                 :value (if (equal (plist-get form :code) "(.pos b)")
                            "(V {:x 1.5 :y 0})"
                          "(Blob {:id 7 :pos (V {:x 1.5 :y 0})})"))))
        (flan-inspect-buffer " *test-inspect*"))
    (when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
    (save-window-excursion
      (flan-inspect--show "b" nil)
      (with-current-buffer " *test-inspect*"
        (goto-char (point-min))
        (flan-inspect-next) (flan-inspect-next)   ; :pos
        (flan-inspect-into)
        (test-flan--check "going in asks for the accessor expression"
                          (equal (car asked) "(.pos b)"))
        (test-flan--check "and the buffer is now showing that"
                          (string-match-p "\\`(\\.pos b)\n" (buffer-string)))
        (test-flan--check "with the stack behind it"
                          (string-match-p "via  b  >  here" (buffer-string)))
        (flan-inspect-pop)
        (test-flan--check "coming back asks for the one we came from"
                          (equal (car asked) "b"))
        (test-flan--check "and there is no stack left"
                          (not (string-match-p "via" (buffer-string))))
        (test-flan--check "popping at the root refuses"
                          (string-match-p
                           "nothing behind it"
                           (or (test-flan--caught #'flan-inspect-pop) "")))))))

;; RET on something that cannot be entered refuses there, rather than sending
;; an expression the program would reject.
(let* ((buf (test-flan--inspect "p" "(Node {:next <ptr> :n 1})")))
  (with-current-buffer buf
    (goto-char (point-min))
    (flan-inspect-next)
    (test-flan--check "RET on a pointer field refuses, naming it"
                      (string-match-p "pointer"
                                      (or (test-flan--caught #'flan-inspect-into) "")))))

;; An atom root has nothing to go into, and the buffer says so rather than
;; drawing an empty field list.
(let ((text (with-current-buffer (test-flan--inspect "(.x p)" "1.5") (buffer-string))))
  (test-flan--check "an atom root explains itself"
                    (string-match-p "Nothing to go into:.*atom" text)))

;; The span bound is drawn, because a field list that silently stops is a lie
;; about the value.
(let ((text (with-current-buffer
                (test-flan--inspect "w" "(Wide {:a 1 :b 2 ...})") (buffer-string))))
  (test-flan--check "span truncation is drawn, not dropped"
                    (string-match-p "span bound of 8" text)))



(message "\n%d checks, %d failures" test-flan--ran test-flan--failures)
(kill-emacs (if (> test-flan--failures 0) 1 0))

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