summaryrefslogtreecommitdiff
path: root/tests/style.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2021-06-17 22:36:59 +0200
committerLudovic Courtès <ludo@gnu.org>2021-07-11 00:49:15 +0200
commitf23803af2018a148fb088f2516d79c20d6bf95f0 (patch)
treee8ac458e7653da290b86f5172d67f15569301afb /tests/style.scm
parent73b08ad1a3ab89223ecbe50478bb2376665f3ffd (diff)
Add 'guix style'.
* guix/scripts/style.scm, tests/style.scm: New files. * Makefile.am (MODULES, SCM_TESTS): Add them. * po/guix/POTFILES.in: Add 'guix/scripts/style.scm'. * doc/guix.texi (Invoking guix style): New node. (package Reference): Reference it. (Invoking guix lint): Likewise.
Diffstat (limited to 'tests/style.scm')
-rw-r--r--tests/style.scm366
1 files changed, 366 insertions, 0 deletions
diff --git a/tests/style.scm b/tests/style.scm
new file mode 100644
index 0000000000..ada9197fc1
--- /dev/null
+++ b/tests/style.scm
@@ -0,0 +1,366 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix 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.
+;;;
+;;; GNU Guix 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests-style)
+ #:use-module (guix packages)
+ #:use-module (guix scripts style)
+ #:use-module ((guix utils) #:select (call-with-temporary-directory))
+ #:use-module ((guix build utils) #:select (substitute*))
+ #:use-module (guix diagnostics)
+ #:use-module (gnu packages acl)
+ #:use-module (gnu packages multiprecision)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-64)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 pretty-print))
+
+(define (call-with-test-package inputs proc)
+ (call-with-temporary-directory
+ (lambda (directory)
+ (call-with-output-file (string-append directory "/my-packages.scm")
+ (lambda (port)
+ (pretty-print
+ `(begin
+ (define-module (my-packages)
+ #:use-module (guix)
+ #:use-module (guix licenses)
+ #:use-module (gnu packages acl)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages multiprecision)
+ #:use-module (srfi srfi-1))
+
+ (define base
+ (package
+ (inherit coreutils)
+ (inputs '())
+ (native-inputs '())
+ (propagated-inputs '())))
+
+ (define (sdl-union . lst)
+ (package
+ (inherit base)
+ (name "sdl-union")))
+
+ (define-public my-coreutils
+ (package
+ (inherit base)
+ ,@inputs
+ (name "my-coreutils"))))
+ port)))
+
+ (proc directory))))
+
+(define test-directory
+ ;; Directory where the package definition lives.
+ (make-parameter #f))
+
+(define-syntax-rule (with-test-package fields exp ...)
+ (call-with-test-package fields
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages.scm"))
+
+ ;; Run as a separate process to make sure FILE is reloaded.
+ (system* "guix" "style" "-L" directory "my-coreutils")
+ (system* "cat" file)
+
+ (load file)
+ (parameterize ((test-directory directory))
+ exp ...))))
+
+(define* (read-lines port line #:optional (count 1))
+ "Read COUNT lines from PORT, starting from LINE."
+ (let loop ((lines '())
+ (count count))
+ (cond ((< (port-line port) (- line 1))
+ (read-char port)
+ (loop lines count))
+ ((zero? count)
+ (string-concatenate-reverse lines))
+ (else
+ (match (read-line port 'concat)
+ ((? eof-object?)
+ (loop lines 0))
+ (line
+ (loop (cons line lines) (- count 1))))))))
+
+(define* (read-package-field package field #:optional (count 1))
+ (let* ((location (package-field-location package field))
+ (file (location-file location))
+ (line (location-line location)))
+ (call-with-input-file (if (string-prefix? "/" file)
+ file
+ (string-append (test-directory) "/"
+ file))
+ (lambda (port)
+ (read-lines port line count)))))
+
+
+(test-begin "style")
+
+(test-equal "nothing to rewrite"
+ '()
+ (with-test-package '()
+ (package-direct-inputs (@ (my-packages) my-coreutils))))
+
+(test-equal "input labels, mismatch"
+ (list `(("foo" ,gmp) ("bar" ,acl))
+ " (inputs `((\"foo\" ,gmp) (\"bar\" ,acl)))\n")
+ (with-test-package '((inputs `(("foo" ,gmp) ("bar" ,acl))))
+ (list (package-direct-inputs (@ (my-packages) my-coreutils))
+ (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
+
+(test-equal "input labels, simple"
+ (list `(("gmp" ,gmp) ("acl" ,acl))
+ " (inputs (list gmp acl))\n")
+ (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
+ (list (package-direct-inputs (@ (my-packages) my-coreutils))
+ (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
+
+(test-equal "input labels, long list with one item per line"
+ (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
+ "\
+ (list gmp
+ acl
+ gmp
+ acl
+ gmp
+ acl
+ gmp
+ acl))\n")
+ (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
+ ("gmp" ,gmp) ("acl" ,acl)
+ ("gmp" ,gmp) ("acl" ,acl)
+ ("gmp" ,gmp) ("acl" ,acl))))
+ (list (package-direct-inputs (@ (my-packages) my-coreutils))
+ (read-package-field (@ (my-packages) my-coreutils) 'inputs 8))))
+
+(test-equal "input labels, sdl-union"
+ "\
+ (list gmp acl
+ (sdl-union 1 2 3 4)))\n"
+ (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
+ ("sdl-union" ,(sdl-union 1 2 3 4)))))
+ (read-package-field (@ (my-packages) my-coreutils) 'inputs 2)))
+
+(test-equal "input labels, output"
+ (list `(("gmp" ,gmp "debug") ("acl" ,acl))
+ " (inputs (list `(,gmp \"debug\") acl))\n")
+ (with-test-package '((inputs `(("gmp" ,gmp "debug") ("acl" ,acl))))
+ (list (package-direct-inputs (@ (my-packages) my-coreutils))
+ (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
+
+(test-equal "input labels, prepend"
+ (list `(("gmp" ,gmp) ("acl" ,acl))
+ "\
+ (modify-inputs (package-propagated-inputs coreutils)
+ (prepend gmp acl)))\n")
+ (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
+ ,@(package-propagated-inputs coreutils))))
+ (list (package-inputs (@ (my-packages) my-coreutils))
+ (read-package-field (@ (my-packages) my-coreutils) 'inputs 2))))
+
+(test-equal "input labels, prepend + delete"
+ (list `(("gmp" ,gmp) ("acl" ,acl))
+ "\
+ (modify-inputs (package-propagated-inputs coreutils)
+ (delete \"gmp\")
+ (prepend gmp acl)))\n")
+ (with-test-package '((inputs `(("gmp" ,gmp)
+ ("acl" ,acl)
+ ,@(alist-delete "gmp"
+ (package-propagated-inputs coreutils)))))
+ (list (package-inputs (@ (my-packages) my-coreutils))
+ (read-package-field (@ (my-packages) my-coreutils) 'inputs 3))))
+
+(test-equal "input labels, prepend + delete multiple"
+ (list `(("gmp" ,gmp) ("acl" ,acl))
+ "\
+ (modify-inputs (package-propagated-inputs coreutils)
+ (delete \"foo\" \"bar\" \"baz\")
+ (prepend gmp acl)))\n")
+ (with-test-package '((inputs `(("gmp" ,gmp)
+ ("acl" ,acl)
+ ,@(fold alist-delete
+ (package-propagated-inputs coreutils)
+ '("foo" "bar" "baz")))))
+ (list (package-inputs (@ (my-packages) my-coreutils))
+ (read-package-field (@ (my-packages) my-coreutils) 'inputs 3))))
+
+(test-equal "input labels, replace"
+ (list '() ;there's no "gmp" input to replace
+ "\
+ (modify-inputs (package-propagated-inputs coreutils)
+ (replace \"gmp\" gmp)))\n")
+ (with-test-package '((inputs `(("gmp" ,gmp)
+ ,@(alist-delete "gmp"
+ (package-propagated-inputs coreutils)))))
+ (list (package-inputs (@ (my-packages) my-coreutils))
+ (read-package-field (@ (my-packages) my-coreutils) 'inputs 2))))
+
+(test-equal "input labels, 'safe' policy"
+ (list `(("gmp" ,gmp) ("acl" ,acl))
+ "\
+ (inputs (list gmp acl))\n")
+ (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))
+ (arguments '())) ;no build system arguments
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages.scm"))
+
+ (system* "guix" "style" "-L" directory "my-coreutils"
+ "--input-simplification=safe")
+
+ (load file)
+ (list (package-inputs (@ (my-packages) my-coreutils))
+ (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
+
+(test-equal "input labels, 'safe' policy, nothing changed"
+ (list `(("GMP" ,gmp) ("ACL" ,acl))
+ "\
+ (inputs `((\"GMP\" ,gmp) (\"ACL\" ,acl)))\n")
+ (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))
+ ;; Non-empty argument list, so potentially unsafe
+ ;; input simplification.
+ (arguments
+ '(#:configure-flags
+ (assoc-ref %build-inputs "GMP"))))
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages.scm"))
+
+ (system* "guix" "style" "-L" directory "my-coreutils"
+ "--input-simplification=safe")
+
+ (load file)
+ (list (package-inputs (@ (my-packages) my-coreutils))
+ (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
+
+(test-equal "input labels, margin comment"
+ (list `(("gmp" ,gmp))
+ `(("acl" ,acl))
+ " (inputs (list gmp)) ;margin comment\n"
+ " (native-inputs (list acl)) ;another one\n")
+ (call-with-test-package '((inputs `(("gmp" ,gmp)))
+ (native-inputs `(("acl" ,acl))))
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages.scm"))
+
+ (substitute* file
+ (("\"gmp\"(.*)$" _ rest)
+ (string-append "\"gmp\"" (string-trim-right rest)
+ " ;margin comment\n"))
+ (("\"acl\"(.*)$" _ rest)
+ (string-append "\"acl\"" (string-trim-right rest)
+ " ;another one\n")))
+ (system* "cat" file)
+
+ (system* "guix" "style" "-L" directory "my-coreutils")
+
+ (load file)
+ (list (package-inputs (@ (my-packages) my-coreutils))
+ (package-native-inputs (@ (my-packages) my-coreutils))
+ (read-package-field (@ (my-packages) my-coreutils) 'inputs)
+ (read-package-field (@ (my-packages) my-coreutils) 'native-inputs)))))
+
+(test-equal "input labels, margin comment on long list"
+ (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
+ "\
+ (list gmp ;margin comment
+ acl
+ gmp ;margin comment
+ acl
+ gmp ;margin comment
+ acl
+ gmp ;margin comment
+ acl))\n")
+ (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
+ ("gmp" ,gmp) ("acl" ,acl)
+ ("gmp" ,gmp) ("acl" ,acl)
+ ("gmp" ,gmp) ("acl" ,acl))))
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages.scm"))
+
+ (substitute* file
+ (("\"gmp\"(.*)$" _ rest)
+ (string-append "\"gmp\"" (string-trim-right rest)
+ " ;margin comment\n")))
+ (system* "cat" file)
+
+ (system* "guix" "style" "-L" directory "my-coreutils")
+
+ (load file)
+ (list (package-inputs (@ (my-packages) my-coreutils))
+ (read-package-field (@ (my-packages) my-coreutils) 'inputs 8)))))
+
+(test-equal "input labels, line comment"
+ (list `(("gmp" ,gmp) ("acl" ,acl))
+ "\
+ (inputs (list gmp
+ ;; line comment!
+ acl))\n")
+ (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages.scm"))
+
+ (substitute* file
+ ((",gmp\\)(.*)$" _ rest)
+ (string-append ",gmp)\n ;; line comment!\n" rest)))
+
+ (system* "guix" "style" "-L" directory "my-coreutils")
+
+ (load file)
+ (list (package-inputs (@ (my-packages) my-coreutils))
+ (read-package-field (@ (my-packages) my-coreutils) 'inputs 3)))))
+
+(test-equal "input labels, modify-inputs and margin comment"
+ (list `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr))
+ "\
+ (modify-inputs (package-propagated-inputs coreutils)
+ (prepend gmp ;margin comment
+ acl ;another one
+ mpfr)))\n")
+ (call-with-test-package '((inputs
+ `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr)
+ ,@(package-propagated-inputs coreutils))))
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages.scm"))
+
+ (substitute* file
+ ((",gmp\\)(.*)$" _ rest)
+ (string-append ",gmp) ;margin comment\n" rest))
+ ((",acl\\)(.*)$" _ rest)
+ (string-append ",acl) ;another one\n" rest)))
+
+ (system* "guix" "style" "-L" directory "my-coreutils")
+
+ (load file)
+ (list (package-inputs (@ (my-packages) my-coreutils))
+ (read-package-field (@ (my-packages) my-coreutils) 'inputs 4)))))
+
+(test-end)
+
+;; Local Variables:
+;; eval: (put 'with-test-package 'scheme-indent-function 1)
+;; eval: (put 'call-with-test-package 'scheme-indent-function 1)
+;; End: