;;; testcover-tests.el --- Testcover test suite   -*- lexical-binding:t -*-

;; Copyright (C) 2017 Free Software Foundation, Inc.

;; Author: Gemini Lasswell

;; This file is part of GNU Emacs.

;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see `http://www.gnu.org/licenses/'.

;;; Commentary:

;; Testcover test suite.
;; * All the test cases are in testcover-resources/testcover-cases.el.
;;   See that file for an explanation of the test case format.
;; * `testcover-tests-define-tests', which is run when this file is
;;   loaded, reads testcover-resources/testcover-cases.el and defines
;;   ERT tests for each test case.

;;; Code:

(require 'ert)
(require 'testcover)
(require 'skeleton)

(defvar testcover-tests-file-dir (file-name-directory (or load-file-name
                                                          buffer-file-name))
  "Directory of the \"testcover-tests.el\" file.")

(defvar testcover-tests-test-cases
  (expand-file-name "testcover-resources/testcases.el"
                    testcover-tests-file-dir)
  "File containing marked up code to instrument and check.")

;; Convert Testcover's overlays to plain text.

(defun testcover-tests-markup-region (beg end &rest optargs)
  "Mark up test code within region between BEG and END.
Convert Testcover's tan and red splotches to %%% and !!! for
testcases.el.  This can be used to create test cases if Testcover
is working correctly on a code sample.  OPTARGS are optional
arguments for `testcover-start'."
  (interactive "r")
  (let ((tempfile (make-temp-file "testcover-tests-" nil ".el"))
        (code (buffer-substring beg end))
        (marked-up-code))
    (unwind-protect
        (progn
          (with-temp-file tempfile
            (insert code))
          (save-current-buffer
            (let ((buf (find-file-noselect tempfile)))
              (set-buffer buf)
              (apply 'testcover-start (cons tempfile optargs))
              (testcover-mark-all buf)
              (dolist (overlay (overlays-in (point-min) (point-max)))
                (let ((ov-face (overlay-get overlay 'face)))
                  (goto-char (overlay-end overlay))
                  (cond
                   ((eq ov-face 'testcover-nohits) (insert "!!!"))
                   ((eq ov-face 'testcover-1value) (insert "%%%"))
                   (t nil))))
              (setq marked-up-code (buffer-string)))
            (set-buffer-modified-p nil)))
      (ignore-errors (kill-buffer (find-file-noselect tempfile)))
      (ignore-errors (delete-file tempfile)))

    ;; Now replace the original code with the marked up code.
    (delete-region beg end)
    (insert marked-up-code)))

(defun testcover-tests-unmarkup-region (beg end)
  "Remove the markup used in testcases.el between BEG and END."
  (interactive "r")
  (save-excursion
    (save-restriction
      (narrow-to-region beg end)
      (goto-char (point-min))
      (while (re-search-forward "!!!\\|%%%" nil t)
        (replace-match "")))))

(define-skeleton testcover-tests-skeleton
  "Write a testcase for testcover-tests.el."
  "Enter name of test: "
  ";; ==== "  str " ====\n"
  "\"docstring\"\n"
  ";; Directives for ERT should go here, if any.\n"
  ";; ====\n"
  ";; Replace this line with annotated test code.\n")

;; Check a test case.

(defun testcover-tests-run-test-case (marked-up-code)
  "Test the operation of Testcover on the string MARKED-UP-CODE."
  (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")))
    (unwind-protect
        (progn
          (with-temp-file tempfile
            (insert marked-up-code))
          ;; Remove the marks and mark the code up again. The original
          ;; and recreated versions should match.
          (save-current-buffer
            (set-buffer (find-file-noselect tempfile))
            ;; Fail the test if the debugger tries to become active,
            ;; which will happen if Testcover's reinstrumentation
            ;; leaves an edebug-enter in the code. This will also
            ;; prevent debugging these tests using Edebug.
            (cl-letf (((symbol-function #'edebug-enter)
                       (lambda (&rest _args)
                         (ert-fail
                          (concat "Debugger invoked during test run "
                                  "(possible edebug-enter not replaced)")))))
              (dolist (byte-compile '(t nil))
                (testcover-tests-unmarkup-region (point-min) (point-max))
                (unwind-protect
                    (testcover-tests-markup-region (point-min) (point-max) byte-compile)
                  (set-buffer-modified-p nil))
                (should (string= marked-up-code
                                 (buffer-string)))))))
      (ignore-errors (kill-buffer (find-file-noselect tempfile)))
      (ignore-errors (delete-file tempfile)))))

;; Convert test case file to ert-defmethod.

(defun testcover-tests-build-test-cases ()
  "Parse the test case file and return a list of ERT test definitions.
Construct and return a list of `ert-deftest' forms.  See testcases.el
for documentation of the test definition format."
  (let (results)
    (with-temp-buffer
      (insert-file-contents testcover-tests-test-cases)
      (goto-char (point-min))
      (while (re-search-forward
              (concat "^;; ==== \\([^ ]+?\\) ====\n"
                      "\\(\\(?:.*\n\\)*?\\)"
                      ";; ====\n"
                      "\\(\\(?:.*\n\\)*?\\)"
                      "\\(\\'\\|;; ====\\)")
              nil t)
        (let ((name (match-string 1))
              (splice (car (read-from-string
                            (format "(%s)" (match-string 2)))))
              (code (match-string 3)))
          (push
           `(ert-deftest ,(intern (concat "testcover-tests-" name)) ()
              ,@splice
              (testcover-tests-run-test-case ,code))
           results))
        (beginning-of-line)))
    results))

;; Define all the tests.

(defmacro testcover-tests-define-tests ()
  "Construct and define ERT test methods using the test case file."
  (let* ((test-cases (testcover-tests-build-test-cases)))
    `(progn ,@test-cases)))

(testcover-tests-define-tests)

(provide 'testcover-tests)

;; Local Variables:
;; no-byte-compile: t
;; End:

;;; testcover-tests.el ends here