code.delx.au - gnu-emacs-elpa/blob - packages/context-coloring/test/context-coloring-coverage.el

   1 ;;; context-coloring-coverage.el --- Test coverage for context coloring  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2014-2015  Free Software Foundation, Inc.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; This program is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; This program is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21
  22 ;; Test coverage support for context coloring.
  23
  24 ;; Use with `make cover'.
  25
  26 ;;; Code:
  27
  28 (require 'json)
  29 (require 'undercover)
  30
  31
  32 (defconst context-coloring-coverage-directory
  33   (file-name-directory (or load-file-name buffer-file-name))
  34   "This file's directory.")
  35
  36 (defun context-coloring-coverage-resolve-path (path)
  37   "Resolve PATH from this file's directory."
  38   (expand-file-name path context-coloring-coverage-directory))
  39
  40 (defconst context-coloring-coverage-output-file-prefix
  41   (format-time-string "%s"))
  42
  43 (defconst context-coloring-coverage-output-directory
  44   (context-coloring-coverage-resolve-path "./coverage/"))
  45
  46 (defconst context-coloring-coverage-output-file
  47   (concat context-coloring-coverage-output-directory
  48           context-coloring-coverage-output-file-prefix ".json"))
  49
  50 (defconst context-coloring-coverage-report-file
  51   (concat context-coloring-coverage-output-directory
  52           context-coloring-coverage-output-file-prefix ".txt"))
  53
  54 (defun context-coloring-coverage-join (strings delimiter)
  55   "Join a list of STRINGS with the string DELIMITER."
  56   (mapconcat 'identity strings delimiter))
  57
  58 (defun context-coloring-coverage-percentage (dividend divisor)
  59   "Get the percentage of DIVIDEND / DIVISOR with precision 2."
  60   (let ((percentage (/ (float (round (* (/ (float dividend) divisor) 10000))) 100)))
  61     (number-to-string
  62      (cond
  63       ((= (mod percentage 1) 0)
  64        ;; Get an integer because we don't like dangling zeros.
  65        (round percentage))
  66       (t
  67        percentage)))))
  68
  69 (defun context-coloring-coverage-format-source-file (source-file)
  70   "Generate a report for SOURCE-FILE's line coverage."
  71   (let* ((source-lines (split-string (cdr (assq 'source source-file)) "\n"))
  72          (coverage (cdr (assq 'coverage source-file)))
  73          (results (list "Hits  | Source"
  74                         (context-coloring-coverage-join (make-vector 80 "-") "")))
  75          (lines-hit 0)
  76          (lines-hittable 0)
  77          hits
  78          source-line)
  79     (while coverage
  80       (setq hits (car coverage))
  81       (setq coverage (cdr coverage))
  82       (setq source-line (car source-lines))
  83       (setq source-lines (cdr source-lines))
  84       (when (not (null hits))
  85         (setq lines-hittable (+ lines-hittable 1))
  86         (when (> hits 0)
  87           (setq lines-hit (+ lines-hit 1))))
  88       (setq results
  89             (append results
  90                     (list (format
  91                            "%-5s %s %s"
  92                            (if hits hits "N/A")
  93                            (if (and hits (= hits 0)) "~" "|")
  94                            source-line)))))
  95     (setq results
  96           (append results
  97                   (list
  98                    ""
  99                    (format
 100                     "Lines: %s / %s"
 101                     lines-hit
 102                     lines-hittable)
 103                    (format
 104                     "Coverage: %s%%"
 105                     (context-coloring-coverage-percentage lines-hit lines-hittable)))))
 106     (context-coloring-coverage-join results "\n")))
 107
 108 (defun context-coloring-coverage-format (coverage-data)
 109   "Generate reports for all files in COVERAGE-DATA."
 110   (context-coloring-coverage-join
 111    (mapcar
 112     'context-coloring-coverage-format-source-file
 113     (cdr (assq 'source_files coverage-data)))
 114    "\n"))
 115
 116 (defun context-coloring-coverage-local-init ()
 117   "Initialize test coverage for local viewing."
 118   (make-directory context-coloring-coverage-output-directory t)
 119   (setq undercover-force-coverage t)
 120   (setenv "COVERALLS_REPO_TOKEN" "noop")
 121   (undercover "context-coloring.el"
 122               (:report-file context-coloring-coverage-output-file))
 123   (add-hook
 124    'kill-emacs-hook
 125    (lambda ()
 126      (let (original-json-array-type
 127            coverage-data
 128            report)
 129        (with-temp-buffer
 130          (insert-file-contents-literally context-coloring-coverage-output-file)
 131          (setq original-json-array-type json-array-type)
 132          (setq json-array-type 'list)
 133          (setq coverage-data
 134                (json-read-from-string
 135                 (buffer-substring-no-properties (point-min) (point-max))))
 136          (setq json-array-type original-json-array-type)
 137          (setq report
 138                (context-coloring-coverage-format coverage-data))
 139          (setq report (concat report "\n")))
 140        (princ report)
 141        (with-temp-buffer
 142          (insert report)
 143          (write-file context-coloring-coverage-report-file))))
 144    t)
 145   (require 'context-coloring))
 146
 147 (defun context-coloring-coverage-ci-init ()
 148   "Initialize test coverage for continuous integration."
 149   (undercover "context-coloring.el")
 150   (require 'context-coloring))
 151
 152 (provide 'context-coloring-coverage)
 153
 154 ;; context-coloring-coverage.el ends here