etest-result-mode.el: Prettier alignment of metadata output.
[ETest.git] / etest-result-mode.el
blob6acf6cf3605da8c737177cecd23e3679cd47c44b
1 ;;; etest-result-mode.el --- Watch tests pass or fail
3 ;; Copyright (C) 2008 Philip Jackson
5 ;; Author: Philip Jackson <phil@shellarchive.co.uk>
7 ;; This file is not currently part of GNU Emacs.
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.
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.
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.
24 ;;; Commentary:
26 ;; The default result mode for etest.
28 (require 'outline)
30 (declare-function etest-resultp "etest")
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))
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.")
44 (defvar etest-rm-ok-re "^ *\\(ok\\) \\.\\."
45 "Regexp that will match good test status.")
47 (defvar etest-status-re
48 (concat "\\(" etest-rm-not-ok-re
49 "\\|" etest-rm-ok-re
50 "\\)")
51 "Regexp that will match a test status.")
53 (defvar etest-meta-info-re
54 (concat "[[:blank:]]"
55 (regexp-opt '("total"
56 "pass"
57 "fail"
58 "started"
59 "finished") t)
60 "..\\{2,\\}[[:blank:]]+\\(.+\\)$")
61 "Regexp that will match the stats at the bottom of the buffer.")
63 (defvar etest-rm-map
64 (let ((m (make-keymap)))
65 (define-key m (kbd "q") 'bury-buffer)
66 (define-key m (kbd "#") 'etest-rm-cycle-comments)
67 (define-key m (kbd "TAB") 'etest-rm-toggle-headline)
68 (define-key m (kbd "<tab>") 'etest-rm-toggle-headline)
69 m))
71 (defvar etest-rm-comment-visibility-types
72 '(show-all show-not-ok show-ok show-none))
74 (defvar etest-rm-comment-visibility-map
75 '((show-all etest-rm-show-all-comments)
76 (show-not-ok etest-rm-hide-ok-comments)
77 (show-ok etest-rm-hide-not-ok-comments)
78 (show-none etest-rm-hide-all-comments))
79 "Defines how the result buffer should look when the user is
80 toggling visibility states.")
82 (defgroup etest nil
83 "Emacs Testing Framework"
84 :group 'lisp)
86 (defun etest-rm-count-string-at-bol (string)
87 "Count how many instances of STRING are at the start of the
88 current line."
89 (save-excursion
90 (goto-char (point-at-bol))
91 (narrow-to-region (point) (point-at-eol))
92 (let ((count 0))
93 (while (looking-at string)
94 (forward-char)
95 (setq count (1+ count)))
96 (widen)
97 count)))
99 (defun etest-rm-outline-level ()
100 "Calculate what the current outline level should be. See
101 `ouline-level' for explination."
102 ;; we add one becuase there is an extra space before a status
103 (1+ (if (looking-at etest-status-re)
104 (etest-rm-count-string-at-bol " ")
105 (etest-rm-count-string-at-bol "*"))))
107 ;;;###autoload
108 (defun etest-result-mode (&optional results meta-info)
109 "Mode used to display test results."
110 (interactive)
111 (kill-all-local-variables)
112 (setq buffer-read-only t)
113 (outline-minor-mode)
114 (set (make-local-variable 'outline-regexp)
115 (concat "\\(\\*\\|"
116 etest-status-re "\\|"
117 etest-meta-info-re "\\)"))
118 (set (make-local-variable 'outline-level)
119 'etest-rm-outline-level)
120 (set (make-local-variable 'current-results) results)
121 (set (make-local-variable 'current-meta-info) meta-info)
122 (setq major-mode 'etest-result-mode)
123 (setq mode-name "etest-result")
124 (set (make-local-variable 'font-lock-defaults)
125 '(etest-rm-font-lock-keywords t t))
126 (use-local-map etest-rm-map)
127 (funcall (cadr (assoc (car etest-rm-comment-visibility-types)
128 etest-rm-comment-visibility-map))))
130 (defun etest-rm-pretty-print-status (result level)
131 "The pretty printing of a single test result. "
132 (let ((returned (plist-get result :result)))
133 (let* ((doc (plist-get result :doc))
134 (comments (plist-get result :comments))
135 (prefix (if returned "ok" "not ok")))
136 (insert (concat " " prefix " "))
137 (insert-char ?\. (- 18 (length prefix) level))
138 (insert ".. ")
139 (let ((col (current-column)))
140 (insert (concat doc "\n"))
141 (when comments
142 (mapc
143 (lambda (comment)
144 (indent-to col)
145 (insert (concat "# " comment "\n")))
146 (split-string comments "\n" t)))))))
148 (defun etest-rm-pretty-print-results (results &optional level)
149 "Pretty print the results of a run to a buffer. See also
150 `etest-rm-pretty-print-status'."
151 (let ((level (or level 0))
152 (res (car results)))
153 (cond
154 ((stringp res)
155 (insert-char ?\* (1+ level))
156 (insert (concat " " res "\n"))
157 (setq level (1+ level)))
158 ((etest-resultp res)
159 (indent-to level)
160 (etest-rm-pretty-print-status res level))
161 ((listp res)
162 (etest-rm-pretty-print-results res level)))
163 (when (cdr results)
164 (etest-rm-pretty-print-results (cdr results) level))))
166 (defun etest-rm-pretty-print-meta-info (meta-info)
167 "Insert a few details about the pass rate."
168 (let* ((pass (float (plist-get meta-info :pass)))
169 (fail (float (plist-get meta-info :fail)))
170 (total (+ pass fail))
171 (start (plist-get meta-info :timestart))
172 (finish (plist-get meta-info :timefinish)))
173 (insert (format (concat "\n total ..... %d\n"
174 " pass ...... %-3d (%3d%%)\n"
175 " fail ...... %-3d (%3d%%)")
176 total
177 pass
178 (* (/ pass total) 100)
179 fail
180 (* (/ fail total) 100)))
181 (insert (format (concat "\n started ... %s\n"
182 " finished .. %s (%f seconds)\n")
183 (current-time-string start)
184 (current-time-string finish)
185 (- (float-time finish) (float-time start))))))
188 (defun etest-rm-refresh-buffer (results &optional meta-info)
189 "Refresh the results buffer using the cached test results."
190 (save-selected-window
191 (switch-to-buffer-other-window (get-buffer-create "*etest*"))
192 (setq buffer-read-only nil)
193 (erase-buffer)
194 (etest-rm-pretty-print-results results 0)
195 (when meta-info
196 (etest-rm-pretty-print-meta-info meta-info))
197 (etest-result-mode results meta-info)
198 (goto-char (point-min))
199 (when (search-forward-regexp etest-rm-not-ok-re nil t)
200 (goto-char (point-at-bol)))))
202 (defconst etest-rm-not-ok-face 'etest-rm-not-ok-face)
203 (defface etest-rm-not-ok-face
204 '((default (:inherit font-lock-warning-face)))
205 "Face used for failing tests."
206 :group 'etest)
208 (defconst etest-rm-ok-face 'etest-rm-ok-face)
209 (defface etest-rm-ok-face
210 '((default (:inherit font-lock-variable-name-face)))
211 "Face used for passing tests."
212 :group 'etest)
214 (defconst etest-rm-comment-face 'etest-rm-comment-face)
215 (defface etest-rm-comment-face
216 '((default (:inherit font-lock-comment-face)))
217 "Face used for comments."
218 :group 'etes)
220 (defconst etest-rm-heading-face 'etest-rm-heading-face)
221 (defface etest-rm-heading-face
222 '((default (:inherit font-lock-keyword-face)))
223 "Face used for headings."
224 :group 'etes)
226 (defconst etest-rm-font-lock-keywords
227 `((,etest-rm-ok-re 1 etest-rm-ok-face)
228 (,etest-rm-not-ok-re 1 etest-rm-not-ok-face)
229 (,etest-meta-info-re 1 etest-rm-heading-face)
230 ("^ *\\(#.+\\)" 1 etest-rm-comment-face)
231 ("^ *\\*+ \\(.+\\)" 1 etest-rm-heading-face)))
233 (defun etest-rm-toggle-headline ()
234 "Toggle the visibility of a test category."
235 (interactive)
236 (unless (looking-at outline-regexp)
237 (outline-previous-heading))
238 (if (get-char-property (point-at-eol) 'invisible)
239 (show-subtree)
240 (hide-subtree)))
242 ;;; comment toggling etc...
244 (defun etest-rm-cycle-comments ()
245 "Shift the values in `etest-rm-comment-visibility-types' and
246 use the `car' of that list to determine the visibility of
247 comments."
248 (interactive)
249 (setq etest-rm-comment-visibility-types
250 (concatenate 'list
251 (cdr etest-rm-comment-visibility-types)
252 (list (car etest-rm-comment-visibility-types))))
253 (etest-rm-refresh-buffer current-results current-meta-info)
254 (message (format "%S" (car etest-rm-comment-visibility-types))))
256 (defmacro etest-with-comments (&rest body)
257 "Eval BODY on each comment in the results buffer."
258 `(save-excursion
259 (goto-char (point-min))
260 (while (search-forward-regexp etest-status-re nil t)
261 (outline-previous-heading)
262 ,@body
263 (forward-line))))
265 (defun etest-rm-hide-not-ok-comments ()
266 "Hide all comments associated with a passing test in a result
267 buffer."
268 (interactive)
269 (etest-with-comments
270 (if (looking-at etest-rm-not-ok-re)
271 (hide-subtree)
272 (show-subtree))))
274 (defun etest-rm-hide-ok-comments ()
275 "Hide all comments associated with a passing test in a result
276 buffer."
277 (interactive)
278 (etest-with-comments
279 (if (looking-at etest-rm-ok-re)
280 (hide-subtree)
281 (show-subtree))))
283 (defun etest-rm-hide-all-comments ()
284 "Hide all comments in a result buffer."
285 (interactive)
286 (etest-with-comments
287 (hide-subtree)))
289 (defun etest-rm-show-all-comments ()
290 "Show all comments in a result buffer."
291 (interactive)
292 (etest-with-comments
293 (show-subtree)))
295 (provide 'etest-result-mode)