[plt-scheme] SchemeUnit elisp code

Hi all,

Below is some elisp code I've been using for a little while
to automate some tedious aspects of using SchemeUnit. 
There is hopefully enough documentation inline to get Emacs
users started without me writing more here.

Cheers,
Noel

;;; Copyright Noel Welsh 2005
;;; Released under Lesser GNU Public Licence

;;; Useful (X)Emacs commands for SchemeUnit

(provide 'schemeunit)

;;; Definitions

(defvar macintosh-p 
  "t if running on a Macintosh (Darwin)"
  (progn
    (save-current-buffer
      (save-excursion
	(set-buffer (get-buffer-create "*Shell Command Output*"))
	(erase-buffer)
	(shell-command "uname")     
	(string= (buffer-string) "Darwin\n")))))

(defvar schemeunit-test-require-spec
  "(require (planet \"test.ss\" (\"schematics\"
\"schemeunit.plt\" 1 1)))")

(defvar schemeunit-text-ui-require-spec
  "(require (planet \"text-ui.ss\" (\"schematics\"
\"schemeunit.plt\" 1 1)))")


(defun schemeunit-lowest-directory (directory)
  "Return just the lowest directory in the given path as a
STRING"
  (first
   (last
    (if macintosh-p
	(split-string-by-char directory ?/)
      (split-path directory))
    2)))

(defun schemeunit-current-directory ()
  "Return the name of the current directory as a STRING"
  (schemeunit-lowest-directory (default-directory)))

(defun schemeunit-all-tests-file-name (directory-name)
  "Given the current directory as a STRING, return the name
   of the file that accumulates all the tests as a STRING"
  (concat (schemeunit-all-tests-suite-name directory-name)
".ss"))

(defun schemeunit-all-tests-suite-name (directory-name)
  "Given the current directory as a STRING, return the name
   of the suite that accumulates all the tests as a STRING"
  (concat "all-"
	  (if (string= directory-name "src")
		""
	      (concat directory-name "-"))
	  "tests"))

(defconst schemeunit-run-tests-file-name 
  "run-tests.ss"
  "The name of the file that runs all the tests; a STRING")

(defun schemeunit-make-file (file-name skeleton)
  (find-file file-name)
  (if (file-exists-p file-name)
      (message (format "File %s already exists" file-name))
    (progn (auto-insert)
	   (funcall skeleton)
	   (save-buffer))))

(defun schemeunit-directory->run-tests-file-name
(directory-name)
  (concat directory-name schemeunit-run-tests-file-name))

(defun schemeunit-directory->all-tests-file-name
(directory-name)
  (schemeunit-all-tests-file-name
   (schemeunit-lowest-directory directory-name)))

(defun schemeunit-file->module-name (file-name)
  (car (split-string (file-name-nondirectory file-name)
"\\.")))

(defun schemeunit-guess-code-file (file-name)
  (concat (schemeunit-guess-code-module file-name) ".ss"))

(defun schemeunit-guess-test-file (file-name)
  (concat (file-name-sans-extension file-name) "-test.ss"))

(defun schemeunit-guess-code-module (file-name)
  (let* ((file (file-name-nondirectory file-name))
	 (end (string-match "-test" file)))
    (substring file 0 end)))

;;; Skeletons

(require 'skeleton)

(define-skeleton
  schemeunit-run-tests-skel
  "Inserts template code for the file that runs all tests
in the
   current directory"
  nil 
  schemeunit-test-require-spec \n
  schemeunit-text-ui-require-spec \n
  "(require \"" (schemeunit-all-tests-file-name
(schemeunit-current-directory)) "\")" \n
  \n
  "(test/text-ui " (schemeunit-all-tests-suite-name
(schemeunit-current-directory)) ")" \n)

(define-skeleton
  schemeunit-all-tests-skel
  "Inserts template code for the file that accumulates all
tests
   in the current directory"
  nil
  "(module " (schemeunit-all-tests-suite-name
(schemeunit-current-directory)) " mzscheme" \n
  \n
  schemeunit-test-require-spec \n  
  "(provide " (schemeunit-all-tests-suite-name
(schemeunit-current-directory)) ")" \n 
  \n
  "(define " (schemeunit-all-tests-suite-name
(schemeunit-current-directory)) \n
  "(make-test-suite " \n
  "\"" (schemeunit-all-tests-suite-name
(schemeunit-current-directory)) "\"" \n
  ";; add suites here" \n
  "))" \n
  ")" \n)

(define-skeleton
  schemeunit-tests-skel
  "Inserts template code for a file containing a test
suite"
  nil
  "(module " (schemeunit-file->module-name
(buffer-file-name)) " mzscheme" \n
  \n
  schemeunit-test-require-spec \n
  "(require \"" (schemeunit-guess-code-file
(buffer-file-name)) "\")" \n
  \n
  "(provide " (schemeunit-guess-code-module
(buffer-file-name)) "-tests)" \n
  \n
  "(define " (schemeunit-guess-code-module
(buffer-file-name)) "-tests" \n
  "(make-test-suite" \n
  "\"All tests for " (schemeunit-guess-code-module
(buffer-file-name)) "\"" \n
  ";;test cases here" \n
  "))" \n
  ")" \n)


;;; User Functions

(defun schemeunit-make-run-tests-file ()
  "Make the file that runs all the tests"
  (interactive) 
  (let* ((directory-name
	  (read-directory-name
	   (format "Directory for %s (Default %S): " 
		   schemeunit-run-tests-file-name
		   (default-directory))
	   (default-directory) 
	   (default-directory)))
	 (file-name
	  (schemeunit-directory->run-tests-file-name
	   directory-name)))
    (schemeunit-make-file file-name
schemeunit-run-tests-skel)))

(defun schemeunit-make-all-tests-file ()
  "Make the file that accumulates all the tests"
  (interactive) 
  (let* ((directory-name
	  (read-directory-name
	   (format "Directory for %s (Default %S): " 
		   schemeunit-run-tests-file-name
		   (default-directory))
	   (default-directory) 
	   (default-directory)))
	 (file-name
	  (schemeunit-directory->all-tests-file-name 
	   directory-name)))
    (schemeunit-make-file file-name
schemeunit-all-tests-skel)))

(defun schemeunit-fill-test-suite ()
  "Fill the current buffer with the skeleton of a test
suite"
  (interactive)
  (schemeunit-tests-skel))

(defun schemeunit-make-all-files ()
  "Make the files to use SchemeUnit in a project.  This
function
   creates a file to accumulate all the tests for a project
and
   a file to run the tests."
  (interactive)
  (let ((directory-name
	 (read-directory-name
	  (format "Directory for tests (Default %S): " 
		  (default-directory))
	  (default-directory) 
	  (default-directory))))
    (schemeunit-make-file
     (schemeunit-directory->run-tests-file-name
directory-name)
     #'schemeunit-run-tests-skel)
    (schemeunit-make-file
     (schemeunit-directory->all-tests-file-name
directory-name)
     #'schemeunit-all-tests-skel)))

(defun schemeunit-run-tests (command)
  "Run SchemeUnit tests via compile (so normal compile
commands
   work on the output).  Command is a STRING"
  (interactive 
   (list (read-from-minibuffer
	  "Command to run tests: "
	  "mzscheme -qe '(begin (load \"run-tests.ss\")
(exit))'")))
  (compile command))


(defun schemeunit-insinuate-quack ()
  "Add key bindings for SchemeUnit to Quack
   Defines the following keys (with your Quack prefix;
default is C-c C-q):
      c  -- Run SchemeUnit tests (schemeunit-run-tests;
think 'compile')
      a  -- Make SchemeUnit files
(schemeunit-make-all-files; think 'all')
      i  -- Fill the current buffer with a test suite
skeleton (schemeunit-fill-test-suite; think 'insert')"
  (interactive)
  (require 'quack)
  (define-key quack-scheme-mode-keymap "c"
'schemeunit-run-tests)
  (define-key quack-scheme-mode-keymap "a"
'schemeunit-make-all-files)
  (define-key quack-scheme-mode-keymap "i" 'schemeunit-fill-test-suite))

Email: noelwelsh <at> yahoo <dot> com   noel <at> untyped <dot> com
AIM: noelhwelsh
Blogs: http://monospaced.blogspot.com/  http://www.untyped.com/untyping/


		
__________________________________ 
Yahoo! Mail - PC Magazine Editors' Choice 2005 
http://mail.yahoo.com