etest-result-mode.el

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