;;; 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)
(require 'flan-cnr)

(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")))
    ;; Backwards is the same list walked the other way. It is tested because
    ;; an asymmetry here is the kind of thing nobody reports and everybody
    ;; notices — and because point lands mid-line after a search, where a
    ;; property-change walk and a field walk disagree.
    (flan-inspect-previous)
    (test-flan--check "p comes back to the second"
                      (equal (get-text-property (point) 'flan-inspect-step)
                             '(:field "name")))
    ;; From the middle of a line, `p' goes to the start of the field point is
    ;; *in*, which is CIDER's behaviour and the reason both commands go
    ;; through one list of field starts: walking property changes from
    ;; mid-line finds the end of the current field instead, and forward and
    ;; backward then disagree about where a field begins.
    (end-of-line)
    (flan-inspect-previous)
    (test-flan--check "from mid-line, p reaches this field's start"
                      (equal (get-text-property (point) 'flan-inspect-step)
                             '(:field "name")))
    (flan-inspect-previous)
    (test-flan--check "and then the one before it"
                      (equal (get-text-property (point) 'flan-inspect-step)
                             '(:field "id")))
    (flan-inspect-previous)
    (test-flan--check "p wraps to the last, as n wraps to the first"
                      (equal (get-text-property (point) 'flan-inspect-step)
                             '(:field "pos")))
    (flan-inspect-next)
    (test-flan--check "and n wraps round from it"
                      (equal (get-text-property (point) 'flan-inspect-step)
                             '(:field "id")))))

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




;;; Restarts: which of them can be taken

(message "\nrestarts, and §4's shadowing")

(let ((rows (flan-cnr-annotate-restarts '("retry" "use-placeholder" "retry" "skip"))))
  (test-flan--check "numbered from zero, innermost first"
                    (equal (mapcar (lambda (r) (nth 0 r)) rows) '(0 1 2 3)))
  (test-flan--check "the first of a name owns it"
                    (null (nth 2 (nth 0 rows))))
  (test-flan--check "a repeat is shadowed by it"
                    (equal (nth 2 (nth 2 rows)) 0))
  (test-flan--check "and a different name is not"
                    (null (nth 2 (nth 3 rows)))))

(test-flan--check "no restarts is a list of no rows"
                  (null (flan-cnr-annotate-restarts nil)))


;;; The break buffer

(message "\nthe break buffer")

(defun test-flan--cnr (state)
  "Draw STATE and return the buffer."
  (let ((buf (get-buffer-create " *test-cnr*")))
    (with-current-buffer buf
      (let ((inhibit-read-only t)) (erase-buffer))
      (flan-cnr-mode)
      (setq flan-cnr--open nil)
      (flan-cnr--render state))
    buf))

;; What the daemon can answer today, and nothing more: a class name and a list
;; of names.
(let* ((buf (test-flan--cnr
             (list :condition "Missing"
                   :restarts '("retry" "use-placeholder" "retry"))))
       (text (with-current-buffer buf (buffer-string))))
  ;; SBCL's order, which is the claim this buffer is making.
  (test-flan--check "the condition is first"
                    (string-match-p "\\`Missing" text))
  (test-flan--check "the restarts are before the stack"
                    (< (string-match "Restarts" text) (string-match "Stack" text)))
  (test-flan--check "restarts are numbered"
                    (string-match-p " 0: \\[retry\\]" text))
  (test-flan--check "a shadowed one has no bracket, as SBCL's has none"
                    (string-match-p " 2:  retry " text))
  (test-flan--check "and says why, and what it would take"
                    (string-match-p "shadowed by 0.*restart-at" text))
  (test-flan--check "abort is the last entry on the same list"
                    (string-match-p " 3: \\[abort\\]" text))
  ;; The rule: nothing implemented is refused by name, with the reason.  These
  ;; three sections exist and are empty, and each says what would fill it.
  ;; The shape of a condition and the values in it are two different
  ;; refusals, and with nothing at all the outer one is what shows.
  (test-flan--check "the condition's fields are refused, not omitted"
                    (string-match-p "Condition fields:\n  not available.*Tast.structs" text))
  ;; The stack is no longer refused for want of a mechanism — the shadow stack
  ;; landed and the daemon answers `backtrace'.  What this fixture has is no
  ;; stack *passed in*, which is the running-program case, so the reason it
  ;; names is that one.
  (test-flan--check "the stack says the program is running, not that it is unbuilt"
                    (string-match-p "Stack.*\n  not available.*running"
                                    (substring text (string-match "--- Stack" text))))
  (test-flan--check "and the keys are shown" (string-match-p "TAB fold a frame" text)))

;; A stopped program with nothing on offer between the error and the top.  It
;; is a real state — spec-conditions §2's `error' with no `restart-case' above
;; it — and it must not look like a bug in the buffer.
(let ((text (with-current-buffer
                (test-flan--cnr (list :condition "Missing" :restarts nil))
              (buffer-string))))
  (test-flan--check "no restarts is said, not drawn blank"
                    (string-match-p "none are active" text))
  (test-flan--check "and abort is still offered"
                    (string-match-p " 0: \\[abort\\]" text)))

;; Taking one sends `restart' with the name.
(let ((sent nil))
  (let ((flan-cnr-request-function
         (lambda (form) (setq sent form) (list :status "ok" :note "accepted"))))
    (with-current-buffer (test-flan--cnr
                          (list :condition "Missing" :restarts '("retry" "skip")))
      (goto-char (point-min))
      (search-forward " 1: ")
      (save-window-excursion (flan-cnr-take))
      (test-flan--check "RET on a restart sends its name"
                        (equal sent '(:op "restart" :name "skip"))))))

;; And a shadowed one is refused here rather than sent, which is the bug in
;; today's `completing-read': it would send "retry" and the *inner* frame would
;; take it, silently.
(let ((sent nil))
  (let ((flan-cnr-request-function (lambda (form) (setq sent form) '(:status "ok"))))
    (with-current-buffer (test-flan--cnr
                          (list :condition "Missing" :restarts '("retry" "a" "retry")))
      (goto-char (point-min))
      (search-forward " 2: ")
      (let ((err (test-flan--caught #'flan-cnr-take)))
        (test-flan--check "a shadowed restart refuses"
                          (and err (string-match-p "shadowed by 0" err)))
        (test-flan--check "and nothing was sent" (null sent))))))

;; A digit takes one, as it does in SBCL.
(let ((sent nil))
  (let ((flan-cnr-request-function
         (lambda (form) (setq sent form) (list :status "ok" :note "accepted"))))
    (with-current-buffer (test-flan--cnr
                          (list :condition "Missing" :restarts '("retry" "skip")))
      (goto-char (point-max))
      (let ((last-command-event ?0))
        (save-window-excursion (call-interactively #'flan-cnr-take-number)))
      (test-flan--check "0 takes the innermost"
                        (equal sent '(:op "restart" :name "retry")))
      (let ((last-command-event ?2))
        (save-window-excursion (call-interactively #'flan-cnr-take-number)))
      (test-flan--check "and the number past the last is abort"
                        (equal sent '(:op "abort"))))))

;; The stack and its locals.  Nothing produces this data today; the fixture is
;; the shape a `backtrace' verb would have to answer with, and building the
;; buffer against it is how it is ready when one exists.
(let* ((state (list :condition "Missing"
                    :restarts '("retry")
                    :stack (list (list :fn "sim/settle" :loc "sand.flan:42:3"
                                       :locals '(("i" "i32" "7")
                                                 ("b" "Blob" "(Blob {:id 7})")))
                                 (list :fn "sim/step" :loc "sand.flan:60:1"
                                       :locals nil))))
       (buf (test-flan--cnr state))
       (text (with-current-buffer buf (buffer-string))))
  (test-flan--check "frames are numbered, innermost first"
                    (string-match-p " 0: > sim/settle" text))
  (test-flan--check "with where they are" (string-match-p "sand.flan:42:3" text))
  (test-flan--check "locals are collapsed to begin with"
                    (not (string-match-p "i32 i = 7" text)))
  (with-current-buffer buf
    (goto-char (point-min))
    (search-forward " 0: > sim/settle")
    (flan-cnr-toggle-frame)
    (test-flan--check "TAB on a frame opens its locals"
                      (string-match-p "i32 i = 7" (buffer-string)))
    (test-flan--check "and the marker turns"
                      (string-match-p " 0: v sim/settle" (buffer-string)))
    ;; A frame whose locals nobody could read says so, in the same place the
    ;; locals would have been.
    (goto-char (point-min))
    (search-forward " 1: > sim/step")
    (flan-cnr-toggle-frame)
    (test-flan--check "a frame with no locals refuses, naming DWARF"
                      (string-match-p "not available.*DWARF" (buffer-string)))
    (goto-char (point-min))
    (search-forward " 0: v sim/settle")
    (flan-cnr-toggle-frame)
    (test-flan--check "and TAB again closes it"
                      (not (string-match-p "i32 i = 7" (buffer-string))))))

;; The two buffers meet: `i' on a local opens the inspector on its name, which
;; is an expression the program can be handed.
(let ((asked nil))
  (let ((flan-inspect-request-function
         (lambda (form) (push (plist-get form :code) asked)
           (list :status "ok" :value "(Blob {:id 7})")))
        (flan-inspect-buffer " *test-inspect*"))
    (with-current-buffer (test-flan--cnr
                          (list :condition "Missing" :restarts '("retry")
                                :stack (list (list :fn "f" :locals '(("b" "Blob" "…"))))))
      (goto-char (point-min))
      (search-forward " 0: > f")
      (flan-cnr-toggle-frame)
      (goto-char (point-min))
      (search-forward "Blob b")
      (save-window-excursion (flan-cnr-inspect))
      (test-flan--check "`i' on a local inspects it by name"
                        (equal (car asked) "b")))))

;; `flan-cnr-show' refuses a running program by name rather than opening an
;; empty buffer.
;; The layout without the values: what a `layout' op alone would buy. The
;; names and the types come out of Tast.structs, which the daemon holds
;; whether or not a program is running; only the values need the pointer the
;; break loop was handed. Drawing the two apart is strictly more than saying
;; nothing, and it is what tells you whether the field you were about to
;; blame is even a field of this condition.
(let ((text (with-current-buffer
                (test-flan--cnr (list :condition "Missing" :restarts '("retry")
                                      :fields '(("path" "string" nil)
                                                ("tried" "i32" "3"))))
              (buffer-string))))
  (test-flan--check "a field is named and typed even with no value"
                    (string-match-p ":path *string *value not available" text))
  (test-flan--check "and the missing value names the verb it needs"
                    (string-match-p "value not available.*agent verb: `condition'" text))
  (test-flan--check "a value that is there is simply shown"
                    (string-match-p ":tried *i32 *3" text)))

;; Backwards through the buffer, for the same reason as in the inspector.
(with-current-buffer (test-flan--cnr
                      (list :condition "Missing" :restarts '("retry" "skip")))
  (goto-char (point-min))
  (search-forward "[abort]")
  (beginning-of-line)
  (flan-cnr-previous)
  (test-flan--check "p from abort lands on the last restart"
                    (equal (get-text-property (point) 'flan-cnr-index) 1))
  (flan-cnr-next)
  (test-flan--check "and n goes back to abort"
                    (get-text-property (point) 'flan-cnr-abort)))


;; The `layout' op, from this side: the condition's own name goes out as
;; `:type' and comes back as fields with no values. Two requests are made for
;; one `C-c C-b' — `break' then `layout' — so the stub records both.
(let ((asked nil))
  (let ((flan-cnr-request-function
         (lambda (form)
           (push form asked)
           (pcase (plist-get form :op)
             ("break" '(:status "ok" :stopped t :condition "sim/Missing"
                        :restarts ("retry")))
             ("layout" '(:status "ok" :type "sim/Missing"
                         :fields (("path" "string") ("tried" "i32"))))))))
    (let ((text (with-current-buffer (save-window-excursion (flan-cnr-show))
                  (buffer-string))))
      (test-flan--check "the condition's name is what `layout' is asked for"
                        (equal (plist-get (car (last asked)) :op) "break"))
      (test-flan--check "and it is sent back verbatim, qualified as it came"
                        (equal (plist-get (car asked) :type) "sim/Missing"))
      (test-flan--check "the fields are drawn, named and typed"
                        (string-match-p ":path *string" text))
      ;; Shape and contents are two different questions, and only the first is
      ;; answerable without the pointer the break loop discards.
      (test-flan--check "and every value still says why it is missing"
                        (string-match-p ":tried *i32 *value not available" text)))))

;; A layout the daemon refuses — a bare name it will not guess between two
;; packages, or a type it cannot place — leaves the section drawing its reason
;; rather than turning `C-c C-b' into an error. The restarts are the decision
;; in front of you and they are still there.
(let ((flan-cnr-request-function
       (lambda (form)
         (pcase (plist-get form :op)
           ("break" '(:status "ok" :stopped t :condition "Missing"
                      :restarts ("retry")))
           ("layout" '(:status "error" :message "Missing is not a qualified name"
                       :candidates ("a/Missing" "b/Missing")))))))
  (let ((text (with-current-buffer (save-window-excursion (flan-cnr-show))
                (buffer-string))))
    (test-flan--check "a refused layout is a section that says so"
                      (string-match-p "not available.*needs a \\*qualified\\* name" text))
    (test-flan--check "and the restarts are drawn anyway"
                      (string-match-p "\\[retry\\]" text))))

(let ((flan-cnr-request-function
       (lambda (_) '(:status "ok" :restarts nil :stopped nil))))
  (test-flan--check "a running program is refused, by name"
                    (string-match-p "no restart stack"
                                    (or (test-flan--caught #'flan-cnr-show) ""))))

(let ((flan-cnr-request-function
       (lambda (_) '(:status "error" :message "the program exited"))))
  (test-flan--check "and the daemon's own refusal is passed through"
                    (string-match-p "the program exited"
                                    (or (test-flan--caught #'flan-cnr-show) ""))))


(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