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   (require 'cl))
  36
  37 ;; The grouping of the status is for convenience and use by the
  38 ;; font-locking so if you change the re don't forget to capture the
  39 ;; status
  40 (defvar etest-rm-not-ok-re "^ *\\(not ok\\) \\.\\."
  41   "Regexp that will match bad test status.")
  42
  43 (defvar etest-rm-ok-re "^ *\\(ok\\) \\.\\."
  44   "Regexp that will match good test status.")
  45
  46 (defvar etest-status-re
  47   (concat "\\(" etest-rm-not-ok-re
  48           "\\|" etest-rm-ok-re
  49           "\\)")
  50   "Regexp that will match a test status.")
  51
  52 (defvar etest-rm-map
  53   (let ((m (make-keymap)))
  54     (define-key m (kbd "q") 'bury-buffer)
  55     (define-key m (kbd "g")
  56       '(lambda ()
  57         (interactive)
  58         (etest-rm-refresh-buffer current-results)))
  59     (define-key m (kbd "#") 'etest-rm-cycle-comments)
  60     (define-key m (kbd "<tab>") 'etest-rm-toggle-headline)
  61     m))
  62
  63 (defvar etest-rm-comment-visibility-types
  64   '(show-all show-not-ok show-ok show-none))
  65
  66 (defvar etest-rm-comment-visibility-map
  67   '((show-all    etest-rm-show-all-comments)
  68     (show-not-ok etest-rm-hide-ok-comments)
  69     (show-ok     etest-rm-hide-not-ok-comments)
  70     (show-none   etest-rm-hide-all-comments))
  71   "Defines how the result buffer should look when the user is
  72 toggling visibility states.")
  73
  74 (defun etest-rm-count-string-at-bol (string)
  75   "Count how many instances of STRING are at the start of the
  76 current line."
  77   (save-excursion
  78     (goto-char (point-at-bol))
  79     (narrow-to-region (point) (point-at-eol))
  80     (let ((count 0))
  81       (while (looking-at string)
  82         (forward-char)
  83         (setq count (1+ count)))
  84       (widen)
  85       count)))
  86
  87 (defun etest-rm-outline-level ()
  88   "Calculate what the current outline level should be. See
  89 `ouline-level' for explination."
  90   ;; we add one becuase there is an extra space before a status
  91   (1+ (if (looking-at etest-status-re)
  92           (etest-rm-count-string-at-bol " ")
  93           (etest-rm-count-string-at-bol "*"))))
  94
  95 ;;;###autoload
  96 (defun etest-result-mode (&optional results)
  97   "Mode used to display test results."
  98   (interactive)
  99   (kill-all-local-variables)
 100   (setq buffer-read-only t)
 101   (outline-minor-mode)
 102   (set (make-local-variable 'outline-regexp)
 103        (concat "\\(\\*\\|" etest-status-re "\\)"))
 104   (set (make-local-variable 'outline-level)
 105        'etest-rm-outline-level)
 106   (set (make-local-variable 'current-results) results)
 107   (setq major-mode 'etest-result-mode)
 108   (setq mode-name "etest-result")
 109   (set (make-local-variable 'font-lock-defaults)
 110        '(etest-rm-font-lock-keywords t t))
 111   (use-local-map etest-rm-map)
 112   (funcall (cadr (assoc (car etest-rm-comment-visibility-types)
 113                         etest-rm-comment-visibility-map))))
 114
 115 (defun etest-rm-pretty-print-status (result level)
 116   "The pretty printing of a single test result. "
 117   (let ((returned (plist-get result :result)))
 118     (let* ((doc (plist-get result :doc))
 119            (comments (plist-get result :comments))
 120            (prefix (if returned "ok" "not ok")))
 121       (insert (concat " " prefix " "))
 122       (insert-char ?\. (- 18 (length prefix) level))
 123       (insert ".. ")
 124       (let ((col (current-column)))
 125       (insert (concat doc "\n"))
 126       (when comments
 127         (mapc
 128          (lambda (comment)
 129            (indent-to col)
 130            (insert (concat "# " comment "\n")))
 131          (split-string comments "\n" t)))))))
 132
 133 (defun etest-rm-pretty-print-results (results &optional level)
 134   "Pretty print the results of a run to a buffer. See also
 135 `etest-rm-pretty-print-status'."
 136   (let ((level (or level 0))
 137         (res (car results)))
 138     (cond
 139       ((stringp res)
 140        (insert-char ?\* (1+ level))
 141        (insert (concat " " res "\n"))
 142        (setq level (1+ level)))
 143       ((etest-resultp res)
 144        (indent-to level)
 145        (etest-rm-pretty-print-status res level))
 146       ((listp res)
 147        (etest-rm-pretty-print-results res level)))
 148     (when (cdr results)
 149       (etest-rm-pretty-print-results (cdr results) level))))
 150
 151 (defun etest-rm-refresh-buffer (results)
 152   "Refresh the results buffer using the cached test results."
 153   (save-selected-window
 154     (switch-to-buffer-other-window (get-buffer-create "*etest*"))
 155     (setq buffer-read-only nil)
 156     (erase-buffer)
 157     (etest-rm-pretty-print-results results 0)
 158     (etest-result-mode results)
 159     (goto-char (point-min))
 160     (when (search-forward-regexp etest-rm-not-ok-re nil t)
 161       (goto-char (point-at-bol)))))
 162
 163 (defconst etest-rm-font-lock-keywords
 164   `((,etest-rm-ok-re     1 font-lock-keyword-face)
 165     (,etest-rm-not-ok-re 1 font-lock-warning-face)
 166     ("^ *\\(#.+\\)"      1 font-lock-comment-face)
 167     ("^ *\\*+ \\(.+\\)"  1 font-lock-variable-name-face)))
 168
 169 (defun etest-rm-toggle-headline ()
 170   "Toggle the visibility of a test category."
 171   (interactive)
 172   (unless (looking-at outline-regexp)
 173     (outline-previous-heading))
 174   (if (get-char-property (point-at-eol) 'invisible)
 175       (show-subtree)
 176       (hide-subtree)))
 177
 178 ;;; comment toggling etc...
 179
 180 (defun etest-rm-cycle-comments ()
 181   "Shift the values in `etest-rm-comment-visibility-types' and
 182 use the `car' of that list to determine the visibility of
 183 comments."
 184   (interactive)
 185   (setq etest-rm-comment-visibility-types
 186         (concatenate 'list
 187                      (cdr etest-rm-comment-visibility-types)
 188                      (list (car etest-rm-comment-visibility-types))))
 189   (etest-rm-refresh-buffer current-results)
 190   (message (format "%S" (car etest-rm-comment-visibility-types))))
 191
 192 (defmacro etest-with-comments (&rest body)
 193   "Eval BODY on each comment in the results buffer."
 194   `(save-excursion
 195      (goto-char (point-min))
 196      (while (search-forward-regexp etest-status-re nil t)
 197        (outline-previous-heading)
 198        ,@body
 199        (forward-line))))
 200
 201 (defun etest-rm-hide-not-ok-comments ()
 202   "Hide all comments associated with a passing test in a result
 203 buffer."
 204   (interactive)
 205   (etest-with-comments
 206    (if (looking-at etest-rm-not-ok-re)
 207      (hide-subtree)
 208      (show-subtree))))
 209
 210 (defun etest-rm-hide-ok-comments ()
 211   "Hide all comments associated with a passing test in a result
 212 buffer."
 213   (interactive)
 214   (etest-with-comments
 215    (if (looking-at etest-rm-ok-re)
 216      (hide-subtree)
 217      (show-subtree))))
 218
 219 (defun etest-rm-hide-all-comments ()
 220   "Hide all comments in a result buffer."
 221   (interactive)
 222   (etest-with-comments
 223    (hide-subtree)))
 224
 225 (defun etest-rm-show-all-comments ()
 226   "Show all comments in a result buffer."
 227   (interactive)
 228   (etest-with-comments
 229    (show-subtree)))
 230
 231 (provide 'etest-result-mode)