guile-semver/tools/coverage.in

#!@GUILE@ --no-auto-compile
-*- scheme -*-
!#
;;; Template for generating lcov coverage reports
;;; guile-semver --- Semantic Versioning tooling for guile

;;; Borrowing code from:
;;; The Geesh Shell Interpreter
;;; Copyright 2017 Timothy Sample <samplet@ngyro.com>

;;;
;;; coverage.in: This file is part of guile-semver.
;;;
;;; guile-semver is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by the Free
;;; Software Foundation; either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; guile-semver is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
;;; for more details.
;;;
;;; You should have received a copy of the GNU General Public License along
;;; with guile-semver.  If not, see <http://www.gnu.org/licenses/>.

(use-modules (ice-9 popen)
             (ice-9 receive)
             (ice-9 textual-ports)
             (srfi srfi-11)
             (srfi srfi-26)
             (system vm coverage)
             (system vm vm))

;; This is a standard Guile function. However, even though it is
;; specified in the manual, it does not support the MODULES
;; keyword. It's only a one-line change, which I've made here.
(define* (coverage-data->lcov data port #:key (modules #f))
  ;; Output per-file coverage data.
  (format port "TN:~%")
  (for-each (lambda (file)
              (let ((path (search-path %load-path file)))
                (if (string? path)
                    (begin
                      (format port "SF:~A~%" path)
                      (for-each (lambda (line+count)
                                  (let ((line  (car line+count))
                                        (count (cdr line+count)))
                                    (format port "DA:~A,~A~%"
                                            (+ 1 line) count)))
                                (line-execution-counts data file))
                      (let-values (((instr exec)
                                    (instrumented/executed-lines data file)))
                        (format port "LH: ~A~%" exec)
                        (format port "LF: ~A~%" instr))
                      (format port "end_of_record~%"))
                    (begin
                      (format (current-error-port)
                              "skipping unknown source file: ~a~%"
                              file)))))
            (or modules (instrumented-source-files data))))

(define (project-file? file)
  "Determine if @var{file} is part of the current project."
  (let ((path (search-path %load-path file)))
    (string-contains path "@abs_top_srcdir@")))

(define (list-tests)
  "List the tests specified in the @file{Makefile}."
  (let* ((port (open-pipe* OPEN_READ "make"
                           "-f" "@abs_top_srcdir@/Makefile" "test-list"))
         (tests (filter (lambda (x)
                          (and (not (string-null? x))
                               (string-suffix? ".scm" x)))
                        (string-split (get-string-all port)
                                      char-whitespace?)))
         (status (close-pipe port)))
    (when (not (eqv? 0 (status:exit-val status)))
      (error "Cannot get test list"))
    (map (cut string-append "@abs_top_srcdir@/" <>) tests)))

(receive (data result)
    (call-with-vm
     (lambda ()
       (set-vm-engine! 'debug)
       (with-code-coverage
           (lambda ()
             (for-each load (list-tests))))))
  (let ((port (open-output-file "lcov.info"))
        (modules (filter project-file? (instrumented-source-files data))))
    (coverage-data->lcov data port #:modules modules)
    (close port)))