From patchwork Fri Oct 7 20:53:47 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: M X-Patchwork-Id: 43213 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id B29EB27BBEA; Fri, 7 Oct 2022 21:54:55 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,FREEMAIL_FROM,MAILING_LIST_MULTI,SPF_HELO_PASS, URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 77A4F27BBE9 for ; Fri, 7 Oct 2022 21:54:54 +0100 (BST) Received: from localhost ([::1]:51320 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1oguMv-0006NL-Lx for patchwork@mira.cbaines.net; Fri, 07 Oct 2022 16:54:53 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:57000) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1oguM8-0005WO-P7 for guix-patches@gnu.org; Fri, 07 Oct 2022 16:54:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:38476) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1oguM8-0002yM-BX for guix-patches@gnu.org; Fri, 07 Oct 2022 16:54:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1oguM8-0003xB-7A for guix-patches@gnu.org; Fri, 07 Oct 2022 16:54:04 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#58365] [PATCH 1/6] gnu: Add guile-test-driver. References: In-Reply-To: Resent-From: Maxime Devos Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 07 Oct 2022 20:54:04 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58365 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 58365@debbugs.gnu.org Cc: Maxime Devos Received: via spool by 58365-submit@debbugs.gnu.org id=B58365.166517604315182 (code B ref 58365); Fri, 07 Oct 2022 20:54:04 +0000 Received: (at 58365) by debbugs.gnu.org; 7 Oct 2022 20:54:03 +0000 Received: from localhost ([127.0.0.1]:37549 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1oguM5-0003wM-GR for submit@debbugs.gnu.org; Fri, 07 Oct 2022 16:54:03 -0400 Received: from laurent.telenet-ops.be ([195.130.137.89]:40926) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1oguM0-0003v1-L1 for 58365@debbugs.gnu.org; Fri, 07 Oct 2022 16:53:59 -0400 Received: from localhost.localdomain ([IPv6:2a02:1811:8c09:9d00:5dba:d409:33f7:a16]) by laurent.telenet-ops.be with bizsmtp id V8tu2800920ykKC018tuFH; Fri, 07 Oct 2022 22:53:55 +0200 From: Maxime Devos Date: Fri, 7 Oct 2022 22:53:47 +0200 Message-Id: <20221007205352.1282-1-maximedevos@telenet.be> X-Mailer: git-send-email 2.37.3 MIME-Version: 1.0 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=telenet.be; s=r22; t=1665176035; bh=PkKo1n9bMrITQ3JXlqu6Tv7ujg4NH68MqDLJm3M2yZc=; h=From:To:Cc:Subject:Date; b=S96SfXOySs0L84SFNQZ3UhZqyTtvBTkQRmDOFvnB13haOAk6ZCRQ/r1S/R9vXVp2l eCaI4QY4O+bxy6gRyZVdkJlSdQYKl9S/PaPkcHeD5IpcXwpC3RyPA2lrzdzm8CNQYr ING5U11V+IR/s6cYCMs9jTipojeWj/YK6cQh8WCTnmbPVEwjffCGHSHaOaHmp21qtR s5zw1/Sma5Mh1My6gqPVVZ2Hph6s72IE1s6zqPQyRZ6zw3fLXW1AUVAvPqRsawQDqK B6QDmLMsVqs/N5+5xJUEIXmb4jRuLOIsCWw+HO9asazIgBv2KzR0klO8vS/KtoOTMq PmCHnV1Hu9rkA== X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches A copy is made of test-driver.scm to avoid potentially surprising rebuilds when changes are made. * gnu/packages/guile.scm (guile-test-driver): New variable. * gnu/packages/aux-files/test-driver.scm: New file. * Makefile.am (AUX_FILES): Register it. * build-aux/test-driver.scm: Add a note. --- Makefile.am | 3 +- build-aux/test-driver.scm | 2 + gnu/packages/aux-files/test-driver.scm | 284 +++++++++++++++++++++++++ gnu/packages/guile.scm | 39 +++- 4 files changed, 326 insertions(+), 2 deletions(-) create mode 100755 gnu/packages/aux-files/test-driver.scm base-commit: 31a56967e2869c916b7a5e8ee570e8e10f0210a5 prerequisite-patch-id: 2712efb97bf33985fd0658e4dd8e936dc08be5fe prerequisite-patch-id: 9d2409b480a8bff0fef029b4b095922d4957e06f prerequisite-patch-id: 51a32abca3efec1ba67ead59b8694c5ea3129ad3 prerequisite-patch-id: 9092927761a340c07a99f5f3ed314a6add04cdee prerequisite-patch-id: d0af09fbd5ee0ef60bdee53b87d729e46c1db2ca prerequisite-patch-id: 4fee177b2d8c9478c6a7b8ce1ca9072942f39863 prerequisite-patch-id: c2b101598fa5b6f93470ae41d51a983dcb931b04 prerequisite-patch-id: 8fe65a852a4463203ea6b92abb3968bd819475b1 prerequisite-patch-id: 7585c78056095ec991615cbbe877e06f713aada9 prerequisite-patch-id: a9fb1bf1718ad8de6fc26d97a7dc5baf41dc38bd prerequisite-patch-id: 1e5c9ef57d1df286042f4ae3eb420394c8b3b045 diff --git a/Makefile.am b/Makefile.am index bfabf0bf2e..e1f1a4573e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -427,7 +427,8 @@ AUX_FILES = \ gnu/packages/aux-files/python/sanity-check.py \ gnu/packages/aux-files/python/sitecustomize.py \ gnu/packages/aux-files/renpy/renpy.in \ - gnu/packages/aux-files/run-in-namespace.c + gnu/packages/aux-files/run-in-namespace.c \ + gnu/packages/aux-files/test-driver.scm # Templates, examples. EXAMPLES = \ diff --git a/build-aux/test-driver.scm b/build-aux/test-driver.scm index 1cdd4ff8f7..7ff8d45031 100755 --- a/build-aux/test-driver.scm +++ b/build-aux/test-driver.scm @@ -2,6 +2,8 @@ exec guile --no-auto-compile -e main -s "$0" "$@" !# ;;;; test-driver.scm - Guile test driver for Automake testsuite harness +;;;; When update this code, consider updating +;;;; gnu/packages/aux-files/test-driver.scm as well. (define script-version "2021-02-02.05") ;UTC diff --git a/gnu/packages/aux-files/test-driver.scm b/gnu/packages/aux-files/test-driver.scm new file mode 100755 index 0000000000..1cdd4ff8f7 --- /dev/null +++ b/gnu/packages/aux-files/test-driver.scm @@ -0,0 +1,284 @@ +#!/bin/sh +exec guile --no-auto-compile -e main -s "$0" "$@" +!# +;;;; test-driver.scm - Guile test driver for Automake testsuite harness + +(define script-version "2021-02-02.05") ;UTC + +;;; Copyright © 2015, 2016 Mathieu Lirzin +;;; Copyright © 2021 Maxim Cournoyer +;;; +;;; This program 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. +;;; +;;; This program 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 this program. If not, see . + +;;;; Commentary: +;;; +;;; This script provides a Guile test driver using the SRFI-64 Scheme API for +;;; test suites. SRFI-64 is distributed with Guile since version 2.0.9. +;;; +;;;; Code: + +(use-modules (ice-9 format) + (ice-9 getopt-long) + (ice-9 pretty-print) + (ice-9 regex) + (srfi srfi-1) + (srfi srfi-19) + (srfi srfi-26) + (srfi srfi-64)) + +(define (show-help) + (display "Usage: + test-driver --test-name=NAME --log-file=PATH --trs-file=PATH + [--expect-failure={yes|no}] [--color-tests={yes|no}] + [--select=REGEXP] [--exclude=REGEXP] [--errors-only={yes|no}] + [--enable-hard-errors={yes|no}] [--brief={yes|no}}] + [--show-duration={yes|no}] [--] + TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS] +The '--test-name' option is mandatory. The '--select' and '--exclude' options +allow selecting or excluding individual test cases via a regexp, respectively. +The '--errors-only' option can be set to \"yes\" to limit the logged test case +metadata to only those test cases that failed. When set to \"yes\", the +'--brief' option disables printing the individual test case result to the +console. When '--show-duration' is set to \"yes\", the time elapsed per test +case is shown.\n")) + +(define %options + '((test-name (value #t)) + (log-file (value #t)) + (trs-file (value #t)) + (select (value #t)) + (exclude (value #t)) + (errors-only (value #t)) + (color-tests (value #t)) + (expect-failure (value #t)) ;XXX: not implemented yet + (enable-hard-errors (value #t)) ;not implemented in SRFI-64 + (brief (value #t)) + (show-duration (value #t)) + (help (single-char #\h) (value #f)) + (version (single-char #\V) (value #f)))) + +(define (option->boolean options key) + "Return #t if the value associated with KEY in OPTIONS is \"yes\"." + (and=> (option-ref options key #f) (cut string=? <> "yes"))) + +(define* (test-display field value #:optional (port (current-output-port)) + #:key pretty?) + "Display \"FIELD: VALUE\\n\" on PORT." + (if pretty? + (begin + (format port "~A:~%" field) + (pretty-print value port #:per-line-prefix "+ ")) + (format port "~A: ~S~%" field value))) + +(define* (result->string symbol #:key colorize?) + "Return SYMBOL as an upper case string. Use colors when COLORIZE is #t." + (let ((result (string-upcase (symbol->string symbol)))) + (if colorize? + (string-append (case symbol + ((pass) "") ;green + ((xfail) "") ;light green + ((skip) "") ;blue + ((fail xpass) "") ;red + ((error) "")) ;magenta + result + "") ;no color + result))) + + +;;; +;;; SRFI 64 custom test runner. +;;; + +(define* (test-runner-gnu test-name #:key color? brief? errors-only? + show-duration? + (out-port (current-output-port)) + (trs-port (%make-void-port "w")) + select exclude) + "Return an custom SRFI-64 test runner. TEST-NAME is a string specifying the +file name of the current the test. COLOR? specifies whether to use colors. +When BRIEF? is true, the individual test cases results are masked and only the +summary is shown. ERRORS-ONLY? reduces the amount of test case metadata +logged to only that of the failed test cases. OUT-PORT and TRS-PORT must be +output ports. OUT-PORT defaults to the current output port, while TRS-PORT +defaults to a void port, which means no TRS output is logged. SELECT and +EXCLUDE may take a regular expression to select or exclude individual test +cases based on their names." + + (define test-cases-start-time (make-hash-table)) + + (define (test-on-test-begin-gnu runner) + ;; Procedure called at the start of an individual test case, before the + ;; test expression (and expected value) are evaluated. + (let ((test-case-name (test-runner-test-name runner)) + (start-time (current-time time-monotonic))) + (hash-set! test-cases-start-time test-case-name start-time))) + + (define (test-skipped? runner) + (eq? 'skip (test-result-kind runner))) + + (define (test-failed? runner) + (not (or (test-passed? runner) + (test-skipped? runner)))) + + (define (test-on-test-end-gnu runner) + ;; Procedure called at the end of an individual test case, when the result + ;; of the test is available. + (let* ((results (test-result-alist runner)) + (result? (cut assq <> results)) + (result (cut assq-ref results <>)) + (test-case-name (test-runner-test-name runner)) + (start (hash-ref test-cases-start-time test-case-name)) + (end (current-time time-monotonic)) + (time-elapsed (time-difference end start)) + (time-elapsed-seconds (+ (time-second time-elapsed) + (* 1e-9 (time-nanosecond time-elapsed))))) + (unless (or brief? (and errors-only? (test-skipped? runner))) + ;; Display the result of each test case on the console. + (format out-port "~a: ~a - ~a ~@[[~,3fs]~]~%" + (result->string (test-result-kind runner) #:colorize? color?) + test-name test-case-name + (and show-duration? time-elapsed-seconds))) + + (unless (and errors-only? (not (test-failed? runner))) + (format #t "test-name: ~A~%" (result 'test-name)) + (format #t "location: ~A~%" + (string-append (result 'source-file) ":" + (number->string (result 'source-line)))) + (test-display "source" (result 'source-form) #:pretty? #t) + (when (result? 'expected-value) + (test-display "expected-value" (result 'expected-value))) + (when (result? 'expected-error) + (test-display "expected-error" (result 'expected-error) #:pretty? #t)) + (when (result? 'actual-value) + (test-display "actual-value" (result 'actual-value))) + (when (result? 'actual-error) + (test-display "actual-error" (result 'actual-error) #:pretty? #t)) + (format #t "result: ~a~%" (result->string (result 'result-kind))) + (newline)) + + (format trs-port ":test-result: ~A ~A [~,3fs]~%" + (result->string (test-result-kind runner)) + (test-runner-test-name runner) time-elapsed-seconds))) + + (define (test-on-group-end-gnu runner) + ;; Procedure called by a 'test-end', including at the end of a test-group. + (let ((fail (or (positive? (test-runner-fail-count runner)) + (positive? (test-runner-xpass-count runner)))) + (skip (or (positive? (test-runner-skip-count runner)) + (positive? (test-runner-xfail-count runner))))) + ;; XXX: The global results need some refinements for XPASS. + (format trs-port ":global-test-result: ~A~%" + (if fail "FAIL" (if skip "SKIP" "PASS"))) + (format trs-port ":recheck: ~A~%" + (if fail "yes" "no")) + (format trs-port ":copy-in-global-log: ~A~%" + (if (or fail skip) "yes" "no")) + (when brief? + ;; Display the global test group result on the console. + (format out-port "~A: ~A~%" + (result->string (if fail 'fail (if skip 'skip 'pass)) + #:colorize? color?) + test-name)) + #f)) + + (let ((runner (test-runner-null))) + (test-runner-on-test-begin! runner test-on-test-begin-gnu) + (test-runner-on-test-end! runner test-on-test-end-gnu) + (test-runner-on-group-end! runner test-on-group-end-gnu) + (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) + runner)) + + +;;; +;;; SRFI 64 test specifiers. +;;; +(define (test-match-name* regexp) + "Return a test specifier that matches a test name against REGEXP." + (lambda (runner) + (string-match regexp (test-runner-test-name runner)))) + +(define (test-match-name*/negated regexp) + "Return a negated test specifier version of test-match-name*." + (lambda (runner) + (not (string-match regexp (test-runner-test-name runner))))) + +;;; XXX: test-match-all is a syntax, which isn't convenient to use with a list +;;; of test specifiers computed at run time. Copy this SRFI 64 internal +;;; definition here, which is the procedural equivalent of 'test-match-all'. +(define (%test-match-all . pred-list) + (lambda (runner) + (let ((result #t)) + (let loop ((l pred-list)) + (if (null? l) + result + (begin + (if (not ((car l) runner)) + (set! result #f)) + (loop (cdr l)))))))) + + +;;; +;;; Entry point. +;;; + +(define (main . args) + (let* ((opts (getopt-long (command-line) %options)) + (option (cut option-ref opts <> <>))) + (cond + ((option 'help #f) (show-help)) + ((option 'version #f) (format #t "test-driver.scm ~A~%" script-version)) + (else + (let* ((log (and=> (option 'log-file #f) (cut open-file <> "w0"))) + (trs (and=> (option 'trs-file #f) (cut open-file <> "wl"))) + (out (duplicate-port (current-output-port) "wl")) + (test-name (option 'test-name #f)) + (select (option 'select #f)) + (exclude (option 'exclude #f)) + (test-specifiers (filter-map + identity + (list (and=> select test-match-name*) + (and=> exclude test-match-name*/negated)))) + (test-specifier (apply %test-match-all test-specifiers)) + (color-tests (if (assoc 'color-tests opts) + (option->boolean opts 'color-tests) + #t))) + (when log + (redirect-port log (current-output-port)) + (redirect-port log (current-warning-port)) + (redirect-port log (current-error-port))) + (test-with-runner + (test-runner-gnu test-name + #:color? color-tests + #:brief? (option->boolean opts 'brief) + #:errors-only? (option->boolean opts 'errors-only) + #:show-duration? (option->boolean + opts 'show-duration) + #:out-port out #:trs-port trs) + (test-apply test-specifier + (lambda _ + (load-from-path test-name)))) + (and=> log close-port) + (and=> trs close-port) + (close-port out)))) + (exit 0))) + +;;; Local Variables: +;;; eval: (add-hook 'write-file-functions 'time-stamp) +;;; time-stamp-start: "(define script-version \"" +;;; time-stamp-format: "%:y-%02m-%02d.%02H" +;;; time-stamp-time-zone: "UTC" +;;; time-stamp-end: "\") ;UTC" +;;; End: + +;;;; test-driver.scm ends here. diff --git a/gnu/packages/guile.scm b/gnu/packages/guile.scm index fcdf75051c..b847ee6be4 100644 --- a/gnu/packages/guile.scm +++ b/gnu/packages/guile.scm @@ -16,7 +16,7 @@ ;;; Copyright © 2018 Eric Bavier ;;; Copyright © 2019 Taylan Kammer ;;; Copyright © 2020, 2021, 2022 Efraim Flashner -;;; Copyright © 2021 Maxime Devos +;;; Copyright © 2021, 2022 Maxime Devos ;;; Copyright © 2021 Timothy Sample ;;; ;;; This file is part of GNU Guix. @@ -60,9 +60,11 @@ (define-module (gnu packages guile) #:use-module (gnu packages version-control) #:use-module (guix packages) #:use-module (guix download) + #:use-module (guix gexp) #:use-module (guix git-download) #:use-module (guix build-system gnu) #:use-module (guix build-system guile) + #:use-module (guix build-system trivial) #:use-module (guix deprecation) #:use-module (guix utils)) @@ -961,4 +963,39 @@ (define-public guile-lzma libraries, like Guile-zlib.") (license license:gpl3+))) +(define-public guile-test-driver + (package + (name "guile-test-driver") + ;; (define script-version ...) in the source code + (version "2021-01-02.05") + ;; 'search-auxiliary-file' could be used here, but that causes warnings. + (source (local-file "../../gnu/packages/aux-files/test-driver.scm")) + (build-system gnu-build-system) + (inputs (list guile-3.0)) + (arguments + (list #:phases + #~(modify-phases %standard-phases + (delete 'configure) + (delete 'check) + (delete 'install) ; no point in separating build and install + (replace 'build + (lambda _ + (define destination + (string-append #$output "/bin/test-driver.scm")) + (mkdir-p (dirname destination)) + (copy-file #$source destination) + (substitute* destination + (("/bin/sh") + ;; Reference to Guile will be patched by patch-shebangs. + "/bin/guile \\") + (("^exec guile(.*)$") "--no-auto-compile -e main -s\n")) + (chmod destination #o500)))))) + (home-page "https://www.gnu.org/software/guix") + (synopsis "Guile test driver for SRFI-64 test suites") + (description "This package, also known as @file{test-driver.scm}, provides +a Guile test driver using the SRFI-64 Scheme API for test suites. Unlike the +default test runner, its output is consistent with other test drivers used +by Automake.") + (license license:gpl3+))) + ;;; guile.scm ends here