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.
26 ;; The default result mode for etest.
30 (declare-function etest-resultp
"etest")
32 ;; calm down byte-compiler, you can have this one...
34 (defvar current-results
)
35 (defvar current-meta-info
)
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
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-rm-todo-re
"^ *\\(todo\\) \\.\\."
48 "Regexp that will match good test status.")
50 (defvar etest-status-re
51 (concat "\\(" etest-rm-not-ok-re
53 "\\|" etest-rm-todo-re
55 "Regexp that will match a test status.")
57 (defvar etest-meta-info-re
64 "..\\{2,\\}[[:blank:]]+\\(.+\\)$")
65 "Regexp that will match the stats at the bottom of the buffer.")
68 (let ((m (make-keymap)))
69 (define-key m
(kbd "q") 'bury-buffer
)
70 (define-key m
(kbd "#") 'etest-rm-cycle-comments
)
71 (define-key m
(kbd "TAB") 'etest-rm-toggle-headline
)
72 (define-key m
(kbd "<tab>") 'etest-rm-toggle-headline
)
75 (defvar etest-rm-comment-visibility-types
76 '(show-all show-not-ok show-ok show-none
))
78 (defvar etest-rm-comment-visibility-map
79 '((show-all etest-rm-show-all-comments
)
80 (show-not-ok etest-rm-hide-ok-comments
)
81 (show-ok etest-rm-hide-not-ok-comments
)
82 (show-none etest-rm-hide-all-comments
))
83 "Defines how the result buffer should look when the user is
84 toggling visibility states.")
87 "Emacs Testing Framework"
90 (defun etest-rm-count-string-at-bol (string)
91 "Count how many instances of STRING are at the start of the
94 (goto-char (point-at-bol))
95 (narrow-to-region (point) (point-at-eol))
97 (while (looking-at string
)
99 (setq count
(1+ count
)))
103 (defun etest-rm-outline-level ()
104 "Calculate what the current outline level should be. See
105 `ouline-level' for explination."
106 ;; we add one becuase there is an extra space before a status
107 (1+ (if (looking-at etest-status-re
)
108 (etest-rm-count-string-at-bol " ")
109 (etest-rm-count-string-at-bol "*"))))
112 (defun etest-result-mode (&optional results meta-info
)
113 "Mode used to display test results."
115 (kill-all-local-variables)
116 (setq buffer-read-only t
)
118 (set (make-local-variable 'outline-regexp
)
120 etest-status-re
"\\|"
121 etest-meta-info-re
"\\)"))
122 (set (make-local-variable 'outline-level
)
123 'etest-rm-outline-level
)
124 (set (make-local-variable 'current-results
) results
)
125 (set (make-local-variable 'current-meta-info
) meta-info
)
126 (setq major-mode
'etest-result-mode
)
127 (setq mode-name
"etest-result")
128 (set (make-local-variable 'font-lock-defaults
)
129 '(etest-rm-font-lock-keywords t t
))
130 (use-local-map etest-rm-map
)
131 (funcall (cadr (assoc (car etest-rm-comment-visibility-types
)
132 etest-rm-comment-visibility-map
))))
134 (defun etest-rm-pretty-print-status (result level
)
135 "The pretty printing of a single test result. "
136 (let ((returned (plist-get result
:result
)))
137 (let* ((doc (plist-get result
:doc
))
138 (comments (plist-get result
:comments
))
141 ((plist-get result
:todo
) "todo")
144 (insert (concat " " prefix
" "))
145 (insert-char ?\.
(- 18 (length prefix
) level
))
147 (let ((col (current-column)))
148 (insert (concat doc
"\n"))
153 (insert (concat "# " comment
"\n")))
154 (split-string comments
"\n" t
)))))))
156 (defun etest-rm-pretty-print-results (results &optional level
)
157 "Pretty print the results of a run to a buffer. See also
158 `etest-rm-pretty-print-status'."
159 (let ((level (or level
0))
163 (insert-char ?\
* (1+ level
))
164 (insert (concat " " res
"\n"))
165 (setq level
(1+ level
)))
168 (etest-rm-pretty-print-status res level
))
170 (etest-rm-pretty-print-results res level
)))
172 (etest-rm-pretty-print-results (cdr results
) level
))))
174 (defun etest-rm-pretty-print-meta-info (meta-info)
175 "Insert a few details about the pass rate."
176 (let* ((pass (float (plist-get meta-info
:pass
)))
177 (fail (float (plist-get meta-info
:fail
)))
178 (total (+ pass fail
))
179 (start (plist-get meta-info
:timestart
))
180 (finish (plist-get meta-info
:timefinish
)))
181 (insert (format (concat "\n total ..... %d\n"
182 " pass ...... %-3d (%3d%%)\n"
183 " fail ...... %-3d (%3d%%)")
186 (* (/ pass total
) 100)
188 (* (/ fail total
) 100)))
189 (insert (format (concat "\n started ... %s\n"
190 " finished .. %s (%f seconds)\n")
191 (current-time-string start
)
192 (current-time-string finish
)
193 (- (float-time finish
) (float-time start
))))))
196 (defun etest-rm-refresh-buffer (results &optional meta-info
)
197 "Refresh the results buffer using the cached test results."
198 (save-selected-window
199 (switch-to-buffer-other-window (get-buffer-create "*etest*"))
200 (setq buffer-read-only nil
)
202 (etest-rm-pretty-print-results results
0)
204 (etest-rm-pretty-print-meta-info meta-info
))
205 (etest-result-mode results meta-info
)
206 (goto-char (point-min))
207 (when (search-forward-regexp etest-rm-not-ok-re nil t
)
208 (goto-char (point-at-bol)))))
210 (defconst etest-rm-not-ok-face
'etest-rm-not-ok-face
)
211 (defface etest-rm-not-ok-face
212 '((default (:inherit font-lock-warning-face
)))
213 "Face used for failing tests."
216 (defconst etest-rm-ok-face
'etest-rm-ok-face
)
217 (defface etest-rm-ok-face
218 '((default (:inherit font-lock-variable-name-face
)))
219 "Face used for passing tests."
222 (defconst etest-rm-comment-face
'etest-rm-comment-face
)
223 (defface etest-rm-comment-face
224 '((default (:inherit font-lock-comment-face
)))
225 "Face used for comments."
228 (defconst etest-rm-heading-face
'etest-rm-heading-face
)
229 (defface etest-rm-heading-face
230 '((default (:inherit font-lock-keyword-face
)))
231 "Face used for headings."
234 (defconst etest-rm-font-lock-keywords
235 `((,etest-rm-ok-re
1 etest-rm-ok-face
)
236 (,etest-rm-not-ok-re
1 etest-rm-not-ok-face
)
237 (,etest-rm-todo-re
1 etest-rm-not-ok-face
)
238 (,etest-meta-info-re
1 etest-rm-heading-face
)
239 ("^ *\\(#.+\\)" 1 etest-rm-comment-face
)
240 ("^ *\\*+ \\(.+\\)" 1 etest-rm-heading-face
)))
242 (defun etest-rm-toggle-headline ()
243 "Toggle the visibility of a test category."
245 (unless (looking-at outline-regexp
)
246 (outline-previous-heading))
247 (if (get-char-property (point-at-eol) 'invisible
)
251 ;;; comment toggling etc...
253 (defun etest-rm-cycle-comments ()
254 "Shift the values in `etest-rm-comment-visibility-types' and
255 use the `car' of that list to determine the visibility of
258 (setq etest-rm-comment-visibility-types
260 (cdr etest-rm-comment-visibility-types
)
261 (list (car etest-rm-comment-visibility-types
))))
262 (etest-rm-refresh-buffer current-results current-meta-info
)
263 (message (format "%S" (car etest-rm-comment-visibility-types
))))
265 (defmacro etest-with-comments
(&rest body
)
266 "Eval BODY on each comment in the results buffer."
268 (goto-char (point-min))
269 (while (search-forward-regexp etest-status-re nil t
)
270 (outline-previous-heading)
274 (defun etest-rm-hide-not-ok-comments ()
275 "Hide all comments associated with a passing test in a result
279 (if (looking-at etest-rm-not-ok-re
)
283 (defun etest-rm-hide-ok-comments ()
284 "Hide all comments associated with a passing test in a result
288 (if (looking-at etest-rm-ok-re
)
292 (defun etest-rm-hide-all-comments ()
293 "Hide all comments in a result buffer."
298 (defun etest-rm-show-all-comments ()
299 "Show all comments in a result buffer."
304 (provide 'etest-result-mode
)