;;; sage-test.el --- Test Sage files

;; Copyright (C) 2008  Nicholas Alexander

;; Author: Nicholas Alexander <ncalexan@pv109055.reshsg.uci.edu>
;; Keywords: sage test


;;; Commentary:
;;

(eval-when-compile (require 'cl))
(require 'sage)
(require 'sage-mode)

;; History of sage-test commands.
;;; Code:

;;;###autoload
(defvar sage-test-history nil)

(defun sage-test-all-tests-passed-p (code)
  "Return t if all tests passed, based off the buffer contents and the return CODE."
  (save-excursion
    (goto-char (point-max))
    (search-backward "All tests passed!" (point-min) t)))

(defun sage-test-process-setup ()
  "Setup compilation variables and buffer for `sage-test'.
Set up `compilation-exit-message-function' and run `sage-test-setup-hook'."
  (set (make-local-variable 'compilation-exit-message-function)
       (lambda (status code msg)
	 (if (eq status 'exit)
	     (if (sage-test-all-tests-passed-p code)
		 '("finished (all test passed)\n" . "all tests passed")
	       '("finished with failing tests\n" . "failing tests"))
	   (cons msg code))))
  (run-hooks 'sage-test-setup-hook))

(defvar sage-test-regexp-alist
  '(("File \"\\(.*?\\)\", line \\([0-9]+\\):"
     1 2)
    ("File \"\\(.*?\\)\", line \\([0-9]+\\),"
     1 2 nil 0)
    )) ;; a `compilation-error-regexp-alist' for sage doctest errors

(defun sage-kill-compilation ()
  "Work hard to really kill sage-test."
  (interactive)
  (dotimes (dummy 50)
    ;; (get-buffer-process (current-buffer))
    (kill-compilation)
    (sleep-for 0 1)))

(define-compilation-mode sage-test-mode "sage-test"
  "Sets `grep-last-buffer' and `compilation-window-height'."
;;   (set (make-local-variable 'compilation-error-face)
;;        grep-hit-face)
;;   (set (make-local-variable 'compilation-disable-input) t)
  (local-set-key [(control c) (control k)] 'sage-kill-compilation)

  (set (make-local-variable 'compilation-error-regexp-alist)
       sage-test-regexp-alist)
  (set (make-local-variable 'compilation-process-setup-function)
       'sage-test-process-setup))


(defun sage-default-test-files ()
  (if (sage-mode-p)
      (buffer-file-name)
    (format "%s*" default-directory)))

(defun sage-default-test-command ()
  "Compute the default sage test command for `sage-test' to offer."
  (format "%s >/dev/null && %s -tp 4 %s" (sage-default-build-command) sage-command (sage-default-test-files)))

(defun sage-default-test-new-command ()
  "Compute the default sage test new command for `sage-test' to offer."
  (format "%s -t %s" sage-command (sage-default-test-files)))

;;;###autoload
(defun sage-test (command-args)
  "Run sage-test, with user-specified args, and collect output in a buffer.
While sage-test runs asynchronously, you can use \\[next-error] (M-x next-error), or
\\<sage-test-mode-map>\\[compile-goto-error] in the sage-test
output buffer, to go to the lines where sage-test found matches.

With prefix arg, default to sage -tnew.

This command uses a special history list for its COMMAND-ARGS, so you can
easily repeat a sage-test command."
  (interactive
   (progn
     (let ((default (sage-default-test-command)))
       (list (read-from-minibuffer "Run sage-test (like this): "
				   (if current-prefix-arg (sage-default-test-new-command) default)
				   nil nil 'sage-test-history
				   (if current-prefix-arg nil default))))))

  ;; Setting process-setup-function makes exit-message-function work
  ;; even when async processes aren't supported.
  (when (buffer-live-p sage-buffer)
    (with-current-buffer sage-buffer
      (compilation-forget-errors)))
  (setq compilation-messages-start nil)
  (compilation-start command-args 'sage-test-mode))

;;;_* "Interactive" doctesting

(defun sage-test-remove-prompts-in-current-buffer ()
  "Modify doctest in buffer to not have any leading sage: and ... prompts."
  (let ((prompt-length nil))
    (goto-char (point-min))
    (re-search-forward sage-test-prompt)
    (setq prompt-length (- (point) 1))

    (goto-char (point-min))
    (delete-char prompt-length)
    (end-of-line)
    (while (not (eobp))
      (forward-line 1)
      (beginning-of-line)
      ;; Handle "blank" doctest lines.  Normally we delete "sage: ",
      ;; but if the line is blank it won't have a trailing space
      (delete-char (min prompt-length
			(- (line-end-position) (point))))
      (end-of-line))))

(defun sage-test-remove-prompts (doctest)
  "Given a doctest snippet, return a string with any leading sage: and ... prompts removed."
  (let ((width tab-width))
    (with-temp-buffer
      (insert doctest)
      ;; clear tabs as best as possible
      (setq tab-width width)
      (untabify (point-min) (point-max))
      ;; remove prompts
      (sage-test-remove-prompts-in-current-buffer)
      (buffer-substring-no-properties (point-min) (point-max)))))

(defun sage-test-doctest-at-point ()
  "Return the doctest at point.
Expects that point is on the same line as a sage: prompt."
  (interactive)

  ;; error checking
  (save-excursion
    (beginning-of-line)
    (unless (looking-at sage-test-prompt)
      (error "Not at a sage: prompt"))

    (let ((beg (point)))
      (forward-line 1)
      (beginning-of-line)
      (while (looking-at (rx (0+ whitespace) "..."))
	;; accumulate additional lines
	(forward-line 1)
	(beginning-of-line))
      ;; back up to end of previous line
      (forward-line -1)
      (end-of-line)
      ;; and return...
      (sage-test-remove-prompts
       (buffer-substring-no-properties beg (point))))))

(defun sage-send-doctest-at-point ()
  "Send the doctest at point to the inferior sage.
Expects that point is on the same line as a sage: prompt."
  ;; (interactive)
  (let* ((doctest (sage-test-doctest-at-point))
	 (one-liner (not (string-match (rx "\n") doctest))))
    (sage-send-command (if one-liner
			   doctest
			 (concat "%cpaste\n" doctest "\n--\n"))
		       t nil)))

(defun sage-fix-doctest-at-point ()
  "Send doctest at point to Sage and replace output with the result.
This is a localized form of `sage --fixdoctects`.
Point must be on the same line as a sage: prompt.

This calls Sage synchronously, so long doctests will freeze Emacs
until they complete."
  (interactive)
  (let* ((doctest (sage-test-doctest-at-point))
	 (indentation (current-indentation))
	 (result (with-temp-buffer
		   ;;
		   (message "Computing %s ..." doctest)
		   (python-send-receive-to-buffer doctest (current-buffer))
		   (buffer-substring-no-properties (point-min) (point-max)))))
    ;; Let you know we are done.
    (if (string-equal result "")
	(message "No result")
      ;; Chop off the trailing \n
      (message "result: %s" (substring result 0 (1- (length result)))))
    (save-restriction
      (sage-test-narrow-to-defun-or-string)
      ;; Move past the doctest
      (forward-line 1)
      (while (looking-at (rx (0+ whitespace) "..."))
	;; accumulate additional lines
	(forward-line 1))
      ;; Select the result
      (let ((start (point)))
	(while (and (not (looking-at
			  (rx (or (and line-start (0+ whitespace) line-end)
				  (and line-start (0+ whitespace) "sage: ")))))
		    (zerop (forward-line 1))))
	;; In case we tried to move past the end of the string...
	(beginning-of-line)
	;; Replace and indent
	(delete-region start (point))
	(insert result)
	(indent-rigidly start (point) indentation)))))

(defun sage-test-narrow-to-defun-or-string ()
  "Narrow to the current docstring if possible, otherwise to the surrounding defun.
Helps interactive doctesting of class/module comments."
  ;; (message "NARROWING %s" (sage-in-string/comment))
  (if (not (sage-in-string/comment))
      (narrow-to-defun)
    (save-excursion
      (let ((beg (nth 8 (syntax-ppss)))) ;;  8. character address of start of comment or string; nil if not in one.
	(when beg
	  (goto-char beg)
	  (forward-sexp 1)
	  (narrow-to-region beg (point)))))))

(defun sage-send-doctest-line-and-forward (&optional noshow)
  "If looking at a 'sage:' prompt, send this line and move to the next prompt
in this docstring.

If NOSHOW is nil, display the Sage process buffer."
  (interactive)
;;   (unless (sage-in-string/comment)
;;     (error "Not in a Sage docstring"))
  (save-excursion
    (beginning-of-line)
    (unless (looking-at sage-test-prompt)
      (error "Not at a sage: prompt"))

    ;; send current line
    (re-search-forward sage-test-prompt)
    (sage-send-doctest-at-point)
    ;; (sage-send-command (sage-test-doctest-at-point) t)
    (unless noshow (display-buffer sage-buffer)))
  (save-restriction
    (sage-test-narrow-to-defun-or-string)
    (end-of-line)
    ;; What must be a bug in Emacs 23.1.1 causes a problem unless we
    ;; force redisplay.  I'm not sure what other versions it affects,
    ;; but it's fixed by 24.1.
    (when (<= emacs-major-version 23)
      (sit-for 0))
    (unless (re-search-forward sage-test-prompt (point-max) t)
      (forward-line 1))
    (end-of-line)))

(defun sage-send-all-doctest-lines (&optional noshow nogo)
  "If in a docstring, send every 'sage:' prompt.

If NOSHOW is nil, display the Sage process buffer.
If NOGO is nil, pop to the Sage process buffer."
  (interactive)
  (unless (sage-in-string/comment)
    (error "Not in a Sage docstring"))
  (sage-beginning-of-string)
  (re-search-forward sage-test-prompt)
  (ignore-errors
    (while t
      (sage-send-doctest-line-and-forward noshow)
      (inferior-sage-wait-for-prompt)))
  (unless nogo
    (pop-to-buffer sage-buffer)))

(defun sage-send-all-doctest-lines-in-file (&optional noshow nogo)
  "Go to the beginning of the file and send every 'sage:' prompt.

If NOSHOW is nil, display the Sage process buffer.
If NOGO is nil, pop to the Sage process buffer."
  (interactive)
  (save-restriction
    (goto-char (point-min))
    (ignore-errors
      (while t
	(re-search-forward sage-test-prompt)
	(sage-send-all-doctest-lines noshow t)
	(inferior-sage-wait-for-prompt))))
  (unless nogo
    (pop-to-buffer sage-buffer)))

(defun sage-retest-failing-files-from-buffer (buffer)
  (interactive "b")
  (save-match-data
    (with-current-buffer buffer
      (let ((files nil)
	    (root (concat (sage-root) "/")))
	(goto-char 0)
	(re-search-forward "^The following tests failed:")
	(while (re-search-forward "\\(devel/.*\\)" (point-max) t)
	  (setq files (cons (concat root (match-string 1)) files)))
	files))))

(defun sage-retest (buffer)
  "Retest only failing files scraped from an existing *sage-test* buffer."
  (interactive "bRetest failing files from buffer: ")
  (let* ((files (sage-retest-failing-files-from-buffer buffer))
	 (files-str (mapconcat #'identity files " ")))
    (flet ((sage-default-test-files () files-str))
      ;; (setq default-directory (sage-current-devel-root))
      (call-interactively 'sage-test))))

;;;###autoload
(defun sage-send-doctest (&optional all)
  "If looking at a sage: prompt, send the current doctest line to the inferior sage.
With prefix argument, send all doctests (at sage: prompts) until
the end of the docstring."
  (interactive "P")
  (sage-maybe-quit-debugger)

  ;; we're going to mangle point and mark, but let's do our damage, figure
  ;; out where we end, and then restore point and mark
  (push-mark) ;; so that you can do `sage-send-doctest' twice easily.

  (let ((end-point nil))
    ;; this may be overkill, but it works for now.
    (save-excursion
      (save-restriction
	(if all
	    (let ((current-prefix-arg nil))
	      (sage-send-all-doctest-lines))
	  (sage-send-doctest-line-and-forward)))
      (setq end-point (point)))
    (goto-char end-point)))

(provide 'sage-test)

;;; sage-test.el ends here