org-tests/tools/el-expectations.el

   1 ;;; el-expectations.el --- minimalist unit testing framework
   2 ;; $Id: el-expectations.el,v 1.47 2008/08/28 19:28:37 rubikitch Exp $
   3
   4 ;; Copyright (C) 2008  rubikitch
   5
   6 ;; Author: rubikitch <rubikitch@ruby-lang.org>
   7 ;; Keywords: lisp, testing, unittest
   8 ;; URL: http://www.emacswiki.org/cgi-bin/wiki/download/el-expectations.el
   9
  10 ;; This file is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; This file is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Emacs Lisp Expectations framework is a minimalist unit testing
  28 ;; framework in Emacs Lisp.
  29
  30 ;; I love Jay Fields' expectations unit testing framework in Ruby. It
  31 ;; provides one syntax and can define various assertions. So I created
  32 ;; Emacs Lisp Expectations modeled after expectations in Ruby.
  33 ;; Testing policy is same as the original expectations in Ruby. Visit
  34 ;; expectations site in rubyforge.
  35 ;; http://expectations.rubyforge.org/
  36
  37 ;; With Emacs Lisp Mock (el-mock.el), Emacs Lisp Expectations supports
  38 ;; mock and stub, ie. behavior based testing.
  39 ;; You can get it from EmacsWiki
  40 ;; http://www.emacswiki.org/cgi-bin/wiki/download/el-mock.el
  41
  42 ;;; Usage:
  43
  44 ;; 1. Evaluate an expectations sexp.
  45 ;; 2. `M-x expectations-execute' to execute a test.
  46 ;; 3. If there are any errors, use M-x next-error (C-x `) and M-x previous-error
  47 ;;    to go to expect sexp in error.
  48
  49 ;; If you evaluated expectations by C-M-x, it is automatically executed.
  50 ;; If you type C-u C-u C-M-x, execute expectations with batch-mode.
  51
  52 ;; For further information: see docstring of `expectations'.
  53 ;; [EVAL IT] (describe-function 'expectations)
  54
  55 ;;; Batch Mode:
  56
  57 ;; Batch mode can be used with this shell script (el-expectations).
  58 ;; Of course, EMACS/OPTIONS/OUTPUT can be customized.
  59
  60 ;; ATTENTION! This script is slightly changed since v1.32.
  61
  62 ;; #!/bin/sh
  63 ;; EMACS=emacs
  64 ;; OPTIONS="-L . -L $HOME/emacs/lisp"
  65 ;; OUTPUT=/tmp/.el-expectations
  66 ;; $EMACS -q --no-site-file --batch $OPTIONS -l el-expectations -f batch-expectations $OUTPUT "$@"
  67 ;; ret=$?
  68 ;; cat $OUTPUT
  69 ;; rm $OUTPUT
  70 ;; exit $ret
  71
  72 ;; $ el-expectations el-expectations-failure-sample.el
  73
  74 ;;; Embedded test:
  75
  76 ;; You can embed test using `fboundp' and `dont-compile'. dont-compile
  77 ;; is needed to prevent unit tests from being byte-compiled.
  78
  79 ;; (dont-compile
  80 ;;   (when (fboundp 'expectations)
  81 ;;     (expectations
  82 ;;       (expect ...)
  83 ;;       ...
  84 ;; )))
  85
  86 ;;; Limitation:
  87
  88 ;; * `expectations-execute' can execute one test (sexp).
  89
  90 ;;; Examples:
  91
  92 ;; Example code is in the EmacsWiki.
  93
  94 ;; Success example http://www.emacswiki.org/cgi-bin/wiki/download/el-expectations-success-sample.el
  95 ;; Failure example http://www.emacswiki.org/cgi-bin/wiki/download/el-expectations-failure-sample.el
  96
  97 ;;; History:
  98
  99 ;; $Log: el-expectations.el,v $
 100 ;; Revision 1.47  2008/08/28 19:28:37  rubikitch
 101 ;; not-called assertion
 102 ;;
 103 ;; Revision 1.46  2008/08/28 19:06:24  rubikitch
 104 ;; `exps-padding': use `window-width'
 105 ;;
 106 ;; Revision 1.45  2008/08/24 20:36:37  rubikitch
 107 ;; mention `dont-compile'
 108 ;;
 109 ;; Revision 1.44  2008/08/22 20:48:52  rubikitch
 110 ;; fixed a stupid bug
 111 ;;
 112 ;; Revision 1.43  2008/08/22 20:43:00  rubikitch
 113 ;; non-nil (true) assertion
 114 ;;
 115 ;; Revision 1.42  2008/04/14 07:54:27  rubikitch
 116 ;; *** empty log message ***
 117 ;;
 118 ;; Revision 1.41  2008/04/14 06:58:20  rubikitch
 119 ;; *** empty log message ***
 120 ;;
 121 ;; Revision 1.40  2008/04/14 06:52:39  rubikitch
 122 ;; better font-lock
 123 ;;
 124 ;; Revision 1.39  2008/04/13 11:49:08  rubikitch
 125 ;; C-u M-x expectations-execute -> batch-expectations-in-emacs
 126 ;;
 127 ;; Revision 1.38  2008/04/13 11:39:51  rubikitch
 128 ;; better result display.
 129 ;;
 130 ;; Revision 1.37  2008/04/13 11:30:17  rubikitch
 131 ;; expectations-eval-defun
 132 ;; batch-expectations-in-emacs
 133 ;;
 134 ;; Revision 1.36  2008/04/12 18:44:24  rubikitch
 135 ;; extend `type' assertion to use predicates.
 136 ;;
 137 ;; Revision 1.35  2008/04/12 14:10:00  rubikitch
 138 ;; updated el-mock info.
 139 ;;
 140 ;; Revision 1.34  2008/04/12 14:08:28  rubikitch
 141 ;; * (require 'el-mock nil t)
 142 ;; * updated `expectations' docstring
 143 ;;
 144 ;; Revision 1.33  2008/04/12 09:49:27  rubikitch
 145 ;; *** empty log message ***
 146 ;;
 147 ;; Revision 1.32  2008/04/12 09:44:23  rubikitch
 148 ;; batch-mode: handle multiple lisp files.
 149 ;;
 150 ;; Revision 1.31  2008/04/12 09:34:32  rubikitch
 151 ;; colorize result summary
 152 ;;
 153 ;; Revision 1.30  2008/04/12 09:19:42  rubikitch
 154 ;; show result summary at the top.
 155 ;;
 156 ;; Revision 1.29  2008/04/12 03:19:06  rubikitch
 157 ;; Execute all expectations in batch mode.
 158 ;;
 159 ;; Revision 1.28  2008/04/12 03:07:43  rubikitch
 160 ;; update doc.
 161 ;;
 162 ;; Revision 1.27  2008/04/10 17:02:40  rubikitch
 163 ;; *** empty log message ***
 164 ;;
 165 ;; Revision 1.26  2008/04/10 14:27:47  rubikitch
 166 ;; arranged code
 167 ;; font-lock support
 168 ;;
 169 ;; Revision 1.25  2008/04/10 12:45:57  rubikitch
 170 ;; mock assertion
 171 ;;
 172 ;; Revision 1.24  2008/04/10 08:46:19  rubikitch
 173 ;; integration of `stub' in el-mock.el
 174 ;;
 175 ;; Revision 1.23  2008/04/10 07:11:40  rubikitch
 176 ;; error data is evaluated.
 177 ;;
 178 ;; Revision 1.22  2008/04/10 06:14:12  rubikitch
 179 ;; added finish message with current time.
 180 ;;
 181 ;; Revision 1.21  2008/04/09 20:45:41  rubikitch
 182 ;; error assertion: with error data
 183 ;;
 184 ;; Revision 1.20  2008/04/09 20:02:46  rubikitch
 185 ;; error-message assertion
 186 ;;
 187 ;; Revision 1.19  2008/04/09 15:07:29  rubikitch
 188 ;; expectations-execute-at-once, eval-defun advice
 189 ;;
 190 ;; Revision 1.18  2008/04/09 08:57:37  rubikitch
 191 ;; Batch Mode documentation
 192 ;;
 193 ;; Revision 1.17  2008/04/09 08:52:34  rubikitch
 194 ;; * (eval-when-compile (require 'cl))
 195 ;; * avoid a warning
 196 ;; * count expectations/failures/errors
 197 ;; * exitstatus = failures + errors (batch mode)
 198 ;;
 199 ;; Revision 1.16  2008/04/09 04:03:11  rubikitch
 200 ;; batch-expectations: use command-line-args-left
 201 ;;
 202 ;; Revision 1.15  2008/04/09 03:54:00  rubikitch
 203 ;; refactored
 204 ;; batch-expectations
 205 ;;
 206 ;; Revision 1.14  2008/04/08 17:54:02  rubikitch
 207 ;; fixed typo
 208 ;;
 209 ;; Revision 1.13  2008/04/08 17:45:08  rubikitch
 210 ;; documentation.
 211 ;; renamed: expectations.el -> el-expectations.el
 212 ;;
 213 ;; Revision 1.12  2008/04/08 16:54:50  rubikitch
 214 ;; changed output format slightly
 215 ;;
 216 ;; Revision 1.11  2008/04/08 16:37:53  rubikitch
 217 ;; error assertion
 218 ;;
 219 ;; Revision 1.10  2008/04/08 15:52:14  rubikitch
 220 ;; refactored
 221 ;;
 222 ;; Revision 1.9  2008/04/08 15:39:06  rubikitch
 223 ;; *** empty log message ***
 224 ;;
 225 ;; Revision 1.8  2008/04/08 15:38:03  rubikitch
 226 ;; reimplementation of exps-assert-*
 227 ;;
 228 ;; Revision 1.7  2008/04/08 15:06:42  rubikitch
 229 ;; better failure handling
 230 ;;
 231 ;; Revision 1.6  2008/04/08 14:45:58  rubikitch
 232 ;; buffer assertion
 233 ;; regexp assertion
 234 ;; type assertion
 235 ;;
 236 ;; Revision 1.5  2008/04/08 13:16:16  rubikitch
 237 ;; removed elk-test dependency
 238 ;;
 239 ;; Revision 1.4  2008/04/08 12:55:15  rubikitch
 240 ;; next-error/occur-like interface
 241 ;;
 242 ;; Revision 1.3  2008/04/08 09:08:54  rubikitch
 243 ;; prettier `desc' display
 244 ;;
 245 ;; Revision 1.2  2008/04/08 08:45:46  rubikitch
 246 ;; exps-last-filename
 247 ;;
 248 ;; Revision 1.1  2008/04/08 07:52:30  rubikitch
 249 ;; Initial revision
 250 ;;
 251
 252 ;;; Code:
 253
 254 (eval-when-compile (require 'cl))
 255 (require 'el-mock nil t)
 256
 257 (defgroup el-expectations nil
 258   "Emacs Lisp Expectations - minimalist unit testing framework."
 259   :group 'lisp)
 260
 261 (defvar exps-last-testcase nil)
 262 (defvar exps-last-filename nil)
 263 (defvar expectations-result-buffer "*expectations result*")
 264
 265 (defcustom expectations-execute-at-once t
 266   "If non-nil, execute selected expectation when pressing C-M-x"
 267   :group 'el-expectations)
 268 (defmacro expectations (&rest body)
 269   "Define a expectations test case.
 270 Use `expect' and `desc' to verify the code.
 271 Note that these are neither functions nor macros.
 272 These are keywords in expectations Domain Specific Language(DSL).
 273
 274 Synopsis:
 275 * (expect EXPECTED-VALUE BODY ...)
 276   Assert that the evaluation result of BODY is `equal' to EXPECTED-VALUE.
 277 * (desc DESCRIPTION)
 278   Description of a test. It is treated only as a delimiter comment.
 279
 280 Synopsis of EXPECTED-VALUE:
 281 * (non-nil)
 282 * (true)
 283   Any non-nil value, eg. t, 1, '(1).
 284
 285 * (buffer BUFFER-NAME)
 286   Body should eq buffer object of BUFFER-NAME.
 287
 288   Example:
 289     (expect (buffer \"*scratch*\")
 290       (with-current-buffer \"*scratch*\"
 291         (current-buffer)))
 292 * (regexp REGEXP)
 293   Body should match REGEXP.
 294
 295   Example:
 296     (expect (regexp \"o\")
 297       \"hoge\")
 298 * (type TYPE-SYMBOL)
 299   Body should be a TYPE-SYMBOL.
 300   TYPE-SYMBOL may be one of symbols returned by `type-of' function.
 301    `symbol', `integer', `float', `string', `cons', `vector',
 302    `char-table', `bool-vector', `subr', `compiled-function',
 303    `marker', `overlay', `window', `buffer', `frame', `process',
 304    `window-configuration'
 305   Otherwise using predicate naming TYPE-SYMBOL and \"p\".
 306   For example, `(type sequence)' uses `sequencep' predicate.
 307   `(type char-or-string)' uses `char-or-string-p' predicate.
 308
 309   Example:
 310     (expect (type buffer)
 311       (current-buffer))
 312     (expect (type sequence)
 313       nil)
 314     (expect (type char-or-string)
 315       \"a\")
 316
 317 * (error)
 318   Body should raise any error.
 319
 320   Example:
 321     (expect (error)
 322       (/ 1 0))
 323 * (error ERROR-SYMBOL)
 324   Body should raise ERROR-SYMBOL error.
 325
 326   Example:
 327     (expect (error arith-error)
 328       (/ 1 0))
 329 * (error ERROR-SYMBOL ERROR-DATA)
 330   Body should raise ERROR-SYMBOL error with ERROR-DATA.
 331   ERROR-DATA is 2nd argument of `signal' function.
 332
 333   Example:
 334     (expect (error wrong-number-of-arguments '(= 3))
 335       (= 1 2 3 ))
 336 * (error-message ERROR-MESSAGE)
 337   Body should raise any error with ERROR-MESSAGE.
 338
 339   Example:
 340     (expect (error-message \"ERROR!!\")
 341       (error \"ERROR!!\"))
 342
 343 * (mock MOCK-FUNCTION-SPEC => MOCK-RETURN-VALUE)
 344   Body should call MOCK-FUNCTION-SPEC and returns MOCK-RETURN-VALUE.
 345   Mock assertion depends on `el-mock' library.
 346   If available, you do not have to require it: el-expectations detects it.
 347
 348   Synopsis of MOCK-FUNCTION-SPEC:
 349     (FUNCTION ARGUMENT ...)
 350     MOCK-FUNCTION-SPEC is almost same as normal function call.
 351     If you should specify `*' as ARGUMENT, any value is accepted.
 352     Otherwise, body should call FUNCTION with specified ARGUMENTs.
 353
 354   Example:
 355     (expect (mock (foo * 3) => nil)
 356       (foo 9 3))
 357
 358 * (not-called FUNCTION)
 359   Body should not call FUNCTION.
 360   Not-called assertion depends on `el-mock' library.
 361   If available, you do not have to require it: el-expectations detects it.
 362
 363   Example:
 364     (expect (not-called hoge)
 365       1)
 366
 367 * any other SEXP
 368   Body should equal (eval SEXP).
 369
 370   Example:
 371     (expect '(1 2)
 372       (list 1 2))
 373
 374 Extending EXPECTED-VALUE is easy. See el-expectations.el source code.
 375
 376 Example:
 377  (expectations
 378    (desc \"simple expectation\")
 379    (expect 3
 380      (+ 1 2))
 381    (expect \"hoge\"
 382      (concat \"ho\" \"ge\"))
 383    (expect \"fuga\"
 384      (set-buffer (get-buffer-create \"tmp\"))
 385      (erase-buffer)
 386      (insert \"fuga\")
 387      (buffer-string))
 388
 389    (desc \"extended expectation\")
 390    (expect (buffer \"*scratch*\")
 391      (with-current-buffer \"*scratch*\"
 392        (current-buffer)))
 393    (expect (regexp \"o\")
 394      \"hoge\")
 395    (expect (type integer)
 396      3)
 397
 398    (desc \"error expectation\")
 399    (expect (error arith-error)
 400      (/ 1 0))
 401    (expect (error)
 402      (/ 1 0))
 403    (desc \"mock with stub\")
 404    (expect (mock (foo 5 * 7) => nil)
 405      ;; Stub function `hoge', which accepts any arguments and returns 3.
 406      (stub hoge => 3)
 407      (foo (+ 2 (hoge 10)) 6 7))
 408    )
 409 "
 410   (if noninteractive
 411       `(setq exps-last-testcase
 412              ',(append exps-last-testcase
 413                        '((new-expectations 1))
 414                       body)
 415              exps-last-filename nil)
 416     `(setq exps-last-testcase ',body
 417            exps-last-filename ,(or load-file-name buffer-file-name))))
 418
 419 (defun exps-execute-test (test)
 420   (destructuring-bind (expect expected . actual)
 421       test
 422     (case expect
 423       (expect
 424           (condition-case e
 425               (exps-assert expected actual)
 426             (error (cons 'error e))))
 427       (desc
 428        (cons 'desc expected))
 429       (new-expectations
 430        (cons 'desc (concat "+++++ New expectations +++++"))))))
 431
 432
 433 (defun expectations-execute (&optional testcase)
 434   "Execute last-defined `expectations' test.
 435 With prefix argument, do `batch-expectations-in-emacs'."
 436   (interactive)
 437   (if current-prefix-arg
 438       (batch-expectations-in-emacs)
 439     (exps-display
 440      (loop for test in (or testcase exps-last-testcase)
 441            collecting (exps-execute-test test)))))
 442
 443 ;;;; assertions
 444 (defvar exps-assert-functions
 445   '(exps-assert-non-nil
 446     exps-assert-true
 447     exps-assert-buffer
 448     exps-assert-regexp
 449     exps-assert-type
 450     exps-assert-error
 451     exps-assert-error-message
 452     exps-assert-mock
 453     exps-assert-not-called
 454     exps-assert-equal-eval))
 455
 456 (defun exps-do-assertion (expected actual symbol evalp test-func msg-func &optional expected-get-func)
 457   (and (consp expected)
 458        (eq symbol (car expected))
 459        (exps-do-assertion-1 (funcall (or expected-get-func #'cadr) expected)
 460                             actual evalp test-func msg-func)))
 461
 462 (defun exps-do-assertion-1 (expected actual evalp test-func msg-func)
 463   (if evalp (setq actual (exps-eval-sexps actual)))
 464   (if (funcall test-func expected actual)
 465       '(pass)
 466     (cons 'fail (funcall msg-func expected actual))))
 467
 468 (defun exps-eval-sexps (sexps)
 469   (let ((fn (lambda () (eval `(progn ,@sexps)))))
 470     (if (fboundp 'mock-protect)
 471         (mock-protect fn)
 472       (funcall fn))))
 473
 474 (defun exps-assert-non-nil (expected actual)
 475   (exps-do-assertion
 476    expected actual 'non-nil t
 477    (lambda (e a) (not (null a)))
 478    (lambda (e a) (format "FAIL: Expected non-nil but was nil"))))
 479
 480 (defun exps-assert-true (expected actual)
 481   (exps-do-assertion
 482    expected actual 'true t
 483    (lambda (e a) (not (null a)))
 484    (lambda (e a) (format "FAIL: Expected non-nil but was nil"))))
 485 (defun exps-assert-buffer (expected actual)
 486   (exps-do-assertion
 487    expected actual 'buffer t
 488    (lambda (e a) (eq (get-buffer e) a))
 489    (lambda (e a) (format "FAIL: Expected <#<buffer %s>> but was <%S>" e a))))
 490
 491 (defun exps-assert-regexp (expected actual)
 492   (exps-do-assertion
 493    expected actual 'regexp t
 494    (lambda (e a) (string-match e a))
 495    (lambda (e a) (format "FAIL: %S should match /%s/" a e))))
 496
 497 (defun exps-assert-type (expected actual)
 498   (exps-do-assertion
 499    expected actual 'type t
 500    (lambda (e a) (or (eq (type-of a) e)
 501                      (let* ((name (symbol-name e))
 502                             (pred (intern
 503                                    (concat name (if (string-match "-" name)
 504                                                     "-p"
 505                                                   "p")))))
 506                      (when (fboundp pred)
 507                        (funcall pred a)))))
 508    (lambda (e a) (format "FAIL: %S is not a %s" a e))))
 509
 510 (defun exps-assert-error (expected actual)
 511   (let (actual-error actual-errdata)
 512     (exps-do-assertion
 513      expected actual 'error nil
 514      (lambda (e a)
 515        (condition-case err
 516            (progn (exps-eval-sexps a) nil)
 517          (error
 518           (setq actual-error err)
 519           (cond ((consp (cadr e))
 520                  (and (eq (car e) (car err))
 521                       (equal (setq actual-errdata (eval (cadr e)))
 522                              (cdr err))))
 523                 (e
 524                  (equal e err))
 525                 (t
 526                  t)))))
 527      (lambda (e a)
 528        (let ((error-type (car e))
 529              (actual-err-string
 530               (if actual-error
 531                   (format ", but raised <%S>" actual-error)
 532                 ", but no error was raised")))
 533          (cond ((and error-type (eq error-type (car actual-error)))
 534                 (format "FAIL: Expected errdata <%S>, but was <%S>" actual-errdata (cdr actual-error)))
 535                (error-type
 536                 (format "FAIL: should raise <%s>%s" error-type actual-err-string))
 537                (t
 538                 (format "FAIL: should raise any error%s" actual-err-string)))))
 539      #'cdr)))
 540
 541 (defun exps-assert-error-message (expected actual)
 542   (let (actual-error-string)
 543     (exps-do-assertion
 544      expected actual 'error-message nil
 545      (lambda (e a)
 546        (condition-case err
 547            (progn (exps-eval-sexps a) nil)
 548          (error
 549           (setq actual-error-string (error-message-string err))
 550           (equal e actual-error-string))))
 551      (lambda (e a)
 552        (if actual-error-string
 553            (format "FAIL: Expected errmsg <%s>, but was <%s>" e actual-error-string)
 554          (format "FAIL: Expected errmsg <%s>, but no error was raised" e))))))
 555
 556
 557 (defun exps-assert-mock (expected actual)
 558   (let (err)
 559     (exps-do-assertion
 560      expected actual 'mock nil
 561      (lambda (e a)
 562        (condition-case me
 563            (progn
 564              (mock-protect
 565               (lambda ()
 566                 (eval `(mock ,@e))
 567                 (eval `(progn ,@a))))
 568              t)
 569          (mock-error (setq err me) nil))
 570        (if err nil t))
 571      (lambda (e a)
 572        (if (eq 'not-called (cadr err))
 573            (format "FAIL: Expected function call <%S>" e)
 574          (destructuring-bind (_  e-args  a-args) err
 575            (format "FAIL: Expected call <%S>, but was <%S>" e-args a-args))))
 576      #'cdr)))
 577
 578 (defun exps-assert-not-called (expected actual)
 579   (let (err)
 580     (exps-do-assertion
 581      expected actual 'not-called nil
 582      (lambda (e a)
 583        (condition-case me
 584            (progn
 585              (mock-protect
 586               (lambda ()
 587                 (eval `(not-called ,@e))
 588                 (eval `(progn ,@a))))
 589              t)
 590          (mock-error (setq err me) nil))
 591        (if err nil t))
 592      (lambda (e a)
 593        (if (eq 'called (cadr err))
 594            (format "FAIL: Expected not-called <%S>" e)))
 595      #'cdr)))
 596 (defun exps-assert-equal-eval (expected actual)
 597   (exps-do-assertion-1
 598    (eval expected) actual t
 599    (lambda (e a) (equal e a))
 600    (lambda (e a) (format "FAIL: Expected <%S> but was <%S>" expected a))))
 601
 602 (defun exps-assert (expected actual)
 603   (run-hook-with-args-until-success 'exps-assert-functions expected actual))
 604
 605 ;;;; next-error interface / occur-mode-like interface
 606 (define-derived-mode exps-display-mode fundamental-mode "EXPECT"
 607   (buffer-disable-undo)
 608   (setq next-error-function 'exps-next-error)
 609   (setq next-error-last-buffer (current-buffer))
 610   (define-key exps-display-mode-map "\C-m" 'exps-goto-expect)
 611   (define-key exps-display-mode-map "\C-c\C-c" 'exps-goto-expect))
 612
 613 (defun exps-padding (desc &optional default-width)
 614   (let ((width
 615          (if noninteractive
 616              (or default-width (string-to-number (or (getenv "WIDTH") "60")))
 617            (window-width (get-buffer-window (current-buffer) t)))))
 618     (make-string (floor (/ (- width 8 (length desc)) 2)) ?=)))
 619
 620 (defun exps-desc (desc &optional default-width)
 621   (let ((padding (exps-padding desc default-width)))
 622     (format "%s %s %s" padding desc padding)))
 623
 624 (defface expectations-red
 625   '((t (:foreground "Red" :bold t)))
 626   "Face for expectations with failure."
 627   :group 'el-expectations)
 628 (defface expectations-green
 629   '((t (:foreground "Green" :bold t)))
 630   "Face for successful expectations."
 631   :group 'el-expectations)
 632 (defvar exps-red-face 'expectations-red)
 633 (defvar exps-green-face 'expectations-green)
 634 (defun exps-result-string (s f e)
 635   (let ((msg1 (format "%d expectations, %d failures, %d errors\n"
 636                       (+ s f e) f e))
 637         (msg2 (format "Expectations finished at %s\n"  (current-time-string))))
 638     (put-text-property 0 (length msg1) 'face
 639                        (if (zerop (+ f e))
 640                            exps-green-face
 641                          exps-red-face) msg1)
 642     (concat msg1 msg2)))
 643
 644 (defun exps-display (results)
 645   (set-buffer (get-buffer-create expectations-result-buffer))
 646   (erase-buffer)
 647   (display-buffer (current-buffer))
 648   (exps-display-mode)
 649   (insert (format "Executing expectations in %s...\n" exps-last-filename))
 650   (loop for result in results
 651         for i from 1
 652         do (insert
 653             (format
 654              "%-3d:%s\n" i
 655              (if (consp result)
 656                  (case (car result)
 657                    (pass "OK")
 658                    (fail (cdr result))
 659                    (error (format "ERROR: %s" (cdr result)))
 660                    (desc (exps-desc (cdr result)))
 661                    (t "not happened!"))
 662                result))))
 663   (insert "\n")
 664   (loop for result in results
 665         for status = (car result)
 666         when (eq 'pass status) collecting result into successes
 667         when (eq 'fail status) collecting result into failures
 668         when (eq 'error status) collecting result into errors
 669         with summary
 670         finally
 671         (destructuring-bind (s f e)
 672             (mapcar #'length (list successes failures errors))
 673           (setq summary (exps-result-string s f e))
 674           (insert summary)
 675           (goto-char (point-min))
 676           (forward-line 1)
 677           (insert summary)
 678           (goto-char (point-min))
 679           (return (+ f e)))))
 680
 681 (defun exps-goto-expect ()
 682   (interactive)
 683   ;; assumes that current-buffer is *expectations result*
 684   (let ((n (progn
 685              (forward-line 0)
 686              (looking-at "^[0-9]+")
 687              (string-to-number (match-string 0)))))
 688     (when exps-last-filename
 689       (with-current-buffer (find-file-noselect exps-last-filename)
 690         (pop-to-buffer (current-buffer))
 691         (goto-char (point-min))
 692         (search-forward "(expectations\n" nil t)
 693         (forward-sexp n)
 694         (forward-sexp -1)))))
 695
 696 (defun exps-next-error (&optional argp reset)
 697   "Move to the Nth (default 1) next failure/error in *expectations result* buffer.
 698 Compatibility function for \\[next-error] invocations."
 699   (interactive "p")
 700   ;; we need to run exps-find-failure from within the *expectations result* buffer
 701   (with-current-buffer
 702       ;; Choose the buffer and make it current.
 703       (if (next-error-buffer-p (current-buffer))
 704           (current-buffer)
 705         (next-error-find-buffer nil nil
 706                                 (lambda ()
 707                                   (eq major-mode 'exps-display-mode))))
 708     (goto-char (cond (reset (point-min))
 709                      ((< argp 0) (line-beginning-position))
 710                      ((> argp 0) (line-end-position))
 711                      ((point))))
 712     (exps-find-failure
 713      (abs argp)
 714      (if (> 0 argp)
 715          #'re-search-backward
 716        #'re-search-forward)
 717      "No more failures")
 718     ;; In case the *expectations result* buffer is visible in a nonselected window.
 719     (let ((win (get-buffer-window (current-buffer) t)))
 720       (if win (set-window-point win (point))))
 721     (exps-goto-expect)))
 722
 723 (defun exps-find-failure (n search-func errmsg)
 724   (loop repeat n do
 725         (unless (funcall search-func "^[0-9]+ *:\\(ERROR\\|FAIL\\)" nil t)
 726           (error errmsg))))
 727
 728 ;;;; edit support
 729 (put 'expect 'lisp-indent-function 1)
 730 (put 'expectations 'lisp-indent-function 0)
 731
 732 ;; (edit-list (quote font-lock-keywords-alist))
 733 (font-lock-add-keywords
 734  'emacs-lisp-mode
 735  '(("\\<\\(expectations\\|expect\\)\\>" 0 font-lock-keyword-face)
 736    (exps-font-lock-desc 0 font-lock-warning-face prepend)
 737    (exps-font-lock-expected-value 0 font-lock-function-name-face prepend)))
 738
 739 (defun exps-font-lock-desc (limit)
 740   (when (re-search-forward "(desc\\s " limit t)
 741     (backward-up-list 1)
 742     (set-match-data (list (point) (progn (forward-sexp 1) (point))))
 743     t))
 744
 745 ;; I think expected value is so-called function name of `expect'.
 746 (defun exps-font-lock-expected-value (limit)
 747   (when (re-search-forward "(expect\\s " limit t)
 748     (forward-sexp 1)
 749     (let ((e (point)))
 750       (forward-sexp -1)
 751       (set-match-data (list (point) e))
 752         t)))
 753
 754 (defun expectations-eval-defun (arg)
 755   "Do `eval-defun'.
 756 If `expectations-execute-at-once' is non-nil, execute expectations if it is an expectations form."
 757   (interactive "P")
 758   (eval-defun arg)
 759   (when expectations-execute-at-once
 760     (save-excursion
 761       (beginning-of-defun)
 762       (and (looking-at "(expectations\\|(.+(fboundp 'expectations)\\|(dont-compile\n.*expectations")
 763            (expectations-execute)))))
 764
 765 (substitute-key-definition 'eval-defun 'expectations-eval-defun emacs-lisp-mode-map)(substitute-key-definition 'eval-defun 'expectations-eval-defun lisp-interaction-mode-map)
 766
 767 ;;;; batch mode
 768 (defun batch-expectations ()
 769   (if (not noninteractive)
 770       (error "`batch-expectations' is to be used only with -batch"))
 771   (destructuring-bind (output-file . lispfiles)
 772       command-line-args-left
 773     (dolist (lispfile lispfiles)
 774       (load lispfile nil t))
 775     (let ((fail-and-errors (expectations-execute)))
 776       (with-current-buffer expectations-result-buffer
 777         (write-region (point-min) (point-max) output-file nil 'nodisp))
 778       (kill-emacs fail-and-errors))))
 779
 780 (defun batch-expectations-in-emacs ()
 781   "Execute expectations in current file with batch mode."
 782   (interactive)
 783   (shell-command (concat "el-expectations " exps-last-filename)
 784                  expectations-result-buffer)
 785   (with-current-buffer expectations-result-buffer
 786     (goto-char (point-min))
 787     (while (re-search-forward "^[0-9].+\\([0-9]\\) failures, \\([0-9]+\\) errors" nil t)
 788       (put-text-property (match-beginning 0) (match-end 0)
 789                          'face
 790                          (if (and (string= "0" (match-string 1))
 791                                   (string= "0" (match-string 2)))
 792                              exps-green-face
 793                            exps-red-face)))))
 794 (provide 'el-expectations)
 795
 796 ;; How to save (DO NOT REMOVE!!)
 797 ;; (emacswiki-post "el-expectations.el")
 798 ;;; el-expectations.el ends here