etest-result-mode.el

   1 ;;; etest-result-mode.el --- Watch tests pass or fail
   2
   3 ;; Copyright (C) 2008 Philip Jackson
   4
   5 ;; Author: Philip Jackson <phil@shellarchive.co.uk>
   6
   7 ;; This file is not currently part of GNU Emacs.
   8
   9 ;; This program is free software; you can redistribute it and/or
  10 ;; modify it under the terms of the GNU General Public License as
  11 ;; published by the Free Software Foundation; either version 2, or (at
  12 ;; your option) any later version.
  13
  14 ;; This program is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 ;; General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program ; see the file COPYING.  If not, write to
  21 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; The default result mode for etest.
  27
  28 (require 'outline)
  29
  30 (declare-function etest-resultp "etest")
  31
  32 ;; calm down byte-compiler, you can have this one...
  33 (eval-when-compile
  34   (defvar current-results)
  35   (defvar current-meta-info)
  36   (require 'cl))
  37
  38 ;; The grouping of the status is for convenience and use by the
  39 ;; font-locking so if you change the re don't forget to capture the
  40 ;; status
  41 (defvar etest-rm-not-ok-re "^ *\\(not ok\\) \\.\\."
  42   "Regexp that will match bad test status.")
  43
  44 (defvar etest-rm-ok-re "^ *\\(ok\\) \\.\\."
  45   "Regexp that will match good test status.")
  46
  47 (defvar etest-rm-todo-re "^ *\\(todo\\) \\.\\."
  48   "Regexp that will match good test status.")
  49
  50 (defvar etest-rm-skip-re "^ *\\(skip\\) \\.\\."
  51   "Regexp that will match good test status.")
  52
  53 (defvar etest-status-re
  54   (concat "\\(" etest-rm-not-ok-re
  55           "\\|" etest-rm-ok-re
  56           "\\|" etest-rm-todo-re
  57           "\\|" etest-rm-skip-re "\\)")
  58       "Regexp that will match a test status.")
  59
  60 (defvar etest-meta-info-re
  61   (concat "[[:blank:]]"
  62           (regexp-opt '("total"
  63                         "pass"
  64                         "fail"
  65                         "started"
  66                         "finished") t)
  67           "..\\{2,\\}[[:blank:]]+\\(.+\\)$")
  68   "Regexp that will match the stats at the bottom of the buffer.")
  69
  70 (defvar etest-rm-map
  71   (let ((m (make-keymap)))
  72     (define-key m (kbd "q") 'bury-buffer)
  73     (define-key m (kbd "#") 'etest-rm-cycle-comments)
  74     (define-key m (kbd "TAB") 'etest-rm-toggle-headline)
  75     (define-key m (kbd "<tab>") 'etest-rm-toggle-headline)
  76     m))
  77
  78 (defvar etest-rm-comment-visibility-types
  79   '(show-all show-not-ok show-ok show-none))
  80
  81 (defvar etest-rm-comment-visibility-map
  82   '((show-all    etest-rm-show-all-comments)
  83     (show-not-ok etest-rm-hide-ok-comments)
  84     (show-ok     etest-rm-hide-not-ok-comments)
  85     (show-none   etest-rm-hide-all-comments))
  86   "Defines how the result buffer should look when the user is
  87 toggling visibility states.")
  88
  89 (defgroup etest nil
  90   "Emacs Testing Framework"
  91   :group 'lisp)
  92
  93 (defun etest-rm-count-string-at-bol (string)
  94   "Count how many instances of STRING are at the start of the
  95 current line."
  96   (save-excursion
  97     (goto-char (point-at-bol))
  98     (narrow-to-region (point) (point-at-eol))
  99     (let ((count 0))
 100       (while (looking-at string)
 101         (forward-char)
 102         (setq count (1+ count)))
 103       (widen)
 104       count)))
 105
 106 (defun etest-rm-outline-level ()
 107   "Calculate what the current outline level should be. See
 108 `ouline-level' for explination."
 109   ;; we add one becuase there is an extra space before a status
 110   (1+ (if (looking-at etest-status-re)
 111           (etest-rm-count-string-at-bol " ")
 112           (etest-rm-count-string-at-bol "*"))))
 113
 114 ;;;###autoload
 115 (defun etest-result-mode (&optional results meta-info)
 116   "Mode used to display test results."
 117   (interactive)
 118   (kill-all-local-variables)
 119   (setq buffer-read-only t)
 120   (outline-minor-mode)
 121   (set (make-local-variable 'outline-regexp)
 122        (concat "\\(\\*\\|"
 123                etest-status-re "\\|"
 124                etest-meta-info-re "\\)"))
 125   (set (make-local-variable 'outline-level)
 126        'etest-rm-outline-level)
 127   (set (make-local-variable 'current-results) results)
 128   (set (make-local-variable 'current-meta-info) meta-info)
 129   (setq major-mode 'etest-result-mode)
 130   (setq mode-name "etest-result")
 131   (set (make-local-variable 'font-lock-defaults)
 132        '(etest-rm-font-lock-keywords t t))
 133   (use-local-map etest-rm-map)
 134   (funcall (cadr (assoc (car etest-rm-comment-visibility-types)
 135                         etest-rm-comment-visibility-map))))
 136
 137 (defun etest-rm-pretty-print-status (result level)
 138   "The pretty printing of a single test result. "
 139   (let ((returned (plist-get result :result)))
 140     (let* ((doc (plist-get result :doc))
 141            (comments (plist-get result :comments))
 142            (prefix (if returned
 143                        (cond
 144                          ((plist-get result :skip) "skip")
 145                          ((plist-get result :todo) "todo")
 146                          (t "ok"))
 147                        "not ok")))
 148       (insert (concat " " prefix " "))
 149       (insert-char ?\. (- 18 (length prefix) level))
 150       (insert ".. ")
 151       (let ((col (current-column)))
 152       (insert (concat doc "\n"))
 153       (when comments
 154         (mapc
 155          (lambda (comment)
 156            (indent-to col)
 157            (insert (concat "# " comment "\n")))
 158          (split-string comments "\n" t)))))))
 159
 160 (defun etest-rm-pretty-print-results (results &optional level)
 161   "Pretty print the results of a run to a buffer. See also
 162 `etest-rm-pretty-print-status'."
 163   (let ((level (or level 0))
 164         (res (car results)))
 165     (cond
 166       ((stringp res)
 167        (insert-char ?\* (1+ level))
 168        (insert (concat " " res "\n"))
 169        (setq level (1+ level)))
 170       ((etest-resultp res)
 171        (indent-to level)
 172        (etest-rm-pretty-print-status res level))
 173       ((listp res)
 174        (etest-rm-pretty-print-results res level)))
 175     (when (cdr results)
 176       (etest-rm-pretty-print-results (cdr results) level))))
 177
 178 (defun etest-rm-pretty-print-meta-info (meta-info)
 179   "Insert a few details about the pass rate."
 180   (let* ((pass (float (plist-get meta-info :pass)))
 181          (fail (float (plist-get meta-info :fail)))
 182          (total (+ pass fail))
 183          (start (plist-get meta-info :timestart))
 184          (finish (plist-get meta-info :timefinish)))
 185     (insert (format (concat "\n total ..... %d\n"
 186                             " pass ...... %-3d (%3d%%)\n"
 187                             " fail ...... %-3d (%3d%%)")
 188                     total
 189                     pass
 190                     (* (/ pass total) 100)
 191                     fail
 192                     (* (/ fail total) 100)))
 193     (insert (format (concat "\n started ... %s\n"
 194                             " finished .. %s (%f seconds)\n")
 195                     (current-time-string start)
 196                     (current-time-string finish)
 197                     (- (float-time finish) (float-time start))))))
 198
 199
 200 (defun etest-rm-refresh-buffer (results &optional meta-info)
 201   "Refresh the results buffer using the cached test results."
 202   (save-selected-window
 203     (switch-to-buffer-other-window (get-buffer-create "*etest*"))
 204     (setq buffer-read-only nil)
 205     (erase-buffer)
 206     (etest-rm-pretty-print-results results 0)
 207     (when meta-info
 208       (etest-rm-pretty-print-meta-info meta-info))
 209     (etest-result-mode results meta-info)
 210     (goto-char (point-min))
 211     (when (search-forward-regexp etest-rm-not-ok-re nil t)
 212       (goto-char (point-at-bol)))))
 213
 214 (defconst etest-rm-not-ok-face 'etest-rm-not-ok-face)
 215 (defface etest-rm-not-ok-face
 216     '((default (:inherit font-lock-warning-face)))
 217   "Face used for failing tests."
 218   :group 'etest)
 219
 220 (defconst etest-rm-ok-face 'etest-rm-ok-face)
 221 (defface etest-rm-ok-face
 222     '((default (:inherit font-lock-variable-name-face)))
 223   "Face used for passing tests."
 224   :group 'etest)
 225
 226 (defconst etest-rm-comment-face 'etest-rm-comment-face)
 227 (defface etest-rm-comment-face
 228     '((default (:inherit font-lock-comment-face)))
 229   "Face used for comments."
 230   :group 'etes)
 231
 232 (defconst etest-rm-heading-face 'etest-rm-heading-face)
 233 (defface etest-rm-heading-face
 234     '((default (:inherit font-lock-keyword-face)))
 235   "Face used for headings."
 236   :group 'etes)
 237
 238 (defconst etest-rm-font-lock-keywords
 239   `((,etest-rm-ok-re     1 etest-rm-ok-face)
 240     (,etest-rm-not-ok-re 1 etest-rm-not-ok-face)
 241     (,etest-rm-todo-re   1 etest-rm-not-ok-face)
 242     (,etest-rm-skip-re   1 etest-rm-not-ok-face)
 243     (,etest-meta-info-re 1 etest-rm-heading-face)
 244     ("^ *\\(#.+\\)"      1 etest-rm-comment-face)
 245     ("^ *\\*+ \\(.+\\)"  1 etest-rm-heading-face)))
 246
 247 (defun etest-rm-toggle-headline ()
 248   "Toggle the visibility of a test category."
 249   (interactive)
 250   (unless (looking-at outline-regexp)
 251     (outline-previous-heading))
 252   (if (get-char-property (point-at-eol) 'invisible)
 253       (show-subtree)
 254       (hide-subtree)))
 255
 256 ;;; comment toggling etc...
 257
 258 (defun etest-rm-cycle-comments ()
 259   "Shift the values in `etest-rm-comment-visibility-types' and
 260 use the `car' of that list to determine the visibility of
 261 comments."
 262   (interactive)
 263   (setq etest-rm-comment-visibility-types
 264         (concatenate 'list
 265                      (cdr etest-rm-comment-visibility-types)
 266                      (list (car etest-rm-comment-visibility-types))))
 267   (etest-rm-refresh-buffer current-results current-meta-info)
 268   (message (format "%S" (car etest-rm-comment-visibility-types))))
 269
 270 (defmacro etest-with-comments (&rest body)
 271   "Eval BODY on each comment in the results buffer."
 272   `(save-excursion
 273      (goto-char (point-min))
 274      (while (search-forward-regexp etest-status-re nil t)
 275        (outline-previous-heading)
 276        ,@body
 277        (forward-line))))
 278
 279 (defun etest-rm-hide-not-ok-comments ()
 280   "Hide all comments associated with a passing test in a result
 281 buffer."
 282   (interactive)
 283   (etest-with-comments
 284    (if (looking-at etest-rm-not-ok-re)
 285      (hide-subtree)
 286      (show-subtree))))
 287
 288 (defun etest-rm-hide-ok-comments ()
 289   "Hide all comments associated with a passing test in a result
 290 buffer."
 291   (interactive)
 292   (etest-with-comments
 293    (if (looking-at etest-rm-ok-re)
 294      (hide-subtree)
 295      (show-subtree))))
 296
 297 (defun etest-rm-hide-all-comments ()
 298   "Hide all comments in a result buffer."
 299   (interactive)
 300   (etest-with-comments
 301    (hide-subtree)))
 302
 303 (defun etest-rm-show-all-comments ()
 304   "Show all comments in a result buffer."
 305   (interactive)
 306   (etest-with-comments
 307    (show-subtree)))
 308
 309 (provide 'etest-result-mode)