;;; test-flan-dape.el --- Drive a real dape session at a Flan program  -*- lexical-binding: t; -*-

;; Run from the repository root, with flan on PATH and dape on the load path:
;;
;;   emacs -Q --batch -L emacs -L /path/to/dape -l emacs/test-flan-dape.el
;;
;; Not part of `dune test'.  It needs Emacs, dape, lldb-dap and a built flan
;; all at once, and wiring four optional things into the acceptance table
;; would make the table's failures mean less rather than more — the DWARF
;; itself is tested there, against LLVM and against lldb directly.  What this
;; adds is the last link: that dape, driving lldb-dap, sets a breakpoint from
;; a .flan buffer, hits it, and reports Flan frames and locals.
;;
;; It exits non-zero and says why if any of that does not happen.

;;; Code:

(require 'flan-mode)
(require 'dape)
(require 'flan-dape)

(defvar flan-dape-test--program "test/programs/debug.flan")
(defvar flan-dape-test--failures 0)

(defun flan-dape-test--fail (fmt &rest args)
  (setq flan-dape-test--failures (1+ flan-dape-test--failures))
  (message "FAIL  %s" (apply #'format fmt args)))

(defun flan-dape-test--ok (what)
  (message "  ok   %s" what))

;; Batch Emacs has no idle loop, so every wait is an explicit pump.
(defun flan-dape-test--pump (pred secs)
  (let ((deadline (+ (float-time) secs)))
    (while (and (< (float-time) deadline) (not (funcall pred)))
      (accept-process-output nil 0.05))
    (funcall pred)))

(defun flan-dape-test--stopped ()
  (dape--live-connection 'stopped t))

(unless (executable-find flan-dape-command)
  (message "test-flan-dape: skipped (no %s on PATH)" flan-dape-command)
  (kill-emacs 0))
(unless (executable-find flan-dape-adapter)
  (message "test-flan-dape: skipped (no %s on PATH)" flan-dape-adapter)
  (kill-emacs 0))

(setq dape-cwd-function (lambda () default-directory))

;; The breakpoint is set in the .flan buffer, by line, before anything is
;; built — which is the only way a person would ever set one, and the thing
;; that cannot work without a line table naming the .flan file.
(with-current-buffer (find-file-noselect flan-dape-test--program)
  (unless (eq major-mode 'flan-mode)
    (flan-dape-test--fail "%s did not open in flan-mode" flan-dape-test--program))
  (unless (eq (key-binding (kbd "C-c C-g")) 'flan-debug)
    (flan-dape-test--fail "C-c C-g is not bound to flan-debug in a Flan buffer"))
  (goto-char (point-min))
  (search-forward "(set (.heat c)")
  (dape-breakpoint-toggle)
  (let ((config (dape--config-eval 'flan nil)))
    ;; `dape--config-eval' is where the unquoted forms in `flan-dape-config'
    ;; turn into strings.  If this is a list rather than a path, `flan-debug'
    ;; handed dape an unevaluated config and lldb would be given a program
    ;; named "(flan-dape--binary ...)".
    (unless (stringp (plist-get config :program))
      (flan-dape-test--fail ":program did not evaluate to a path: %S"
                            (plist-get config :program)))
    (unless (zerop (call-process-shell-command (plist-get config 'compile) nil nil))
      (flan-dape-test--fail "the configured build failed: %s"
                            (plist-get config 'compile))
      (kill-emacs 1))
    (flan-dape-test--ok "the config builds the program it points lldb at")
    (dape config 'skip-compile)))

(if (not (flan-dape-test--pump #'flan-dape-test--stopped 60))
    (flan-dape-test--fail "the session never stopped at the entry point")
  (flan-dape-test--ok "lldb-dap launched and stopped at entry")
  (dape-continue (flan-dape-test--stopped))
  ;; The entry stop has to clear before the next one counts as the breakpoint.
  (flan-dape-test--pump (lambda () (not (flan-dape-test--stopped))) 5)
  (if (not (flan-dape-test--pump #'flan-dape-test--stopped 60))
      (flan-dape-test--fail "the breakpoint in %s never hit" flan-dape-test--program)
    (let* ((conn (flan-dape-test--stopped))
           (thread (car (dape--threads conn)))
           (frames (plist-get thread :stackFrames))
           (top (car frames)))
      (flan-dape-test--ok "the breakpoint hit")
      (unless (equal (plist-get top :name) "flan.tick")
        (flan-dape-test--fail "the top frame is %S, wanted flan.tick"
                              (plist-get top :name)))
      (unless (equal (plist-get (plist-get top :source) :name) "debug.flan")
        (flan-dape-test--fail "the top frame's source is %S, wanted debug.flan"
                              (plist-get (plist-get top :source) :name)))
      (unless (integerp (plist-get top :line))
        (flan-dape-test--fail "the top frame has no line number"))
      (flan-dape-test--ok
       (format "frame %s at %s:%s" (plist-get top :name)
               (plist-get (plist-get top :source) :name) (plist-get top :line)))
      ;; Locals, which dape fetches lazily — so they are asked for here.
      (let ((seen nil) (done nil))
        (dape-request
         conn :scopes (list :frameId (plist-get top :id))
         (lambda (body _err)
           (dolist (scope (append (plist-get body :scopes) nil))
             (dape-request
              conn :variables
              (list :variablesReference (plist-get scope :variablesReference))
              (lambda (body _err)
                (dolist (v (append (plist-get body :variables) nil))
                  (push (list (plist-get v :type) (plist-get v :name)
                              (plist-get v :value))
                        seen)))))
           (setq done t)))
        (flan-dape-test--pump (lambda () done) 15)
        (accept-process-output nil 1.0)
        (dolist (want '(("int" "n" "41") ("Cell *" "c" nil)))
          (let ((hit (seq-find (lambda (v)
                                 (and (equal (nth 0 v) (nth 0 want))
                                      (equal (nth 1 v) (nth 1 want))
                                      (or (null (nth 2 want))
                                          (equal (nth 2 v) (nth 2 want)))))
                               seen)))
            (if hit
                (flan-dape-test--ok (format "%s %s = %s" (nth 0 hit) (nth 1 hit)
                                            (nth 2 hit)))
              (flan-dape-test--fail "no local %s of type %s; saw %S"
                                    (nth 1 want) (nth 0 want) seen))))))))

(ignore-errors (dape-kill (dape--live-connection 'parent)))

(if (zerop flan-dape-test--failures)
    (progn (message "flan-dape: all tests passed") (kill-emacs 0))
  (message "%d failure(s)" flan-dape-test--failures)
  (kill-emacs 1))

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