1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
11 ;;; GNU Guix is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19 (define-module (tests-style)
20 #:use-module (guix packages)
21 #:use-module (guix scripts style)
22 #:use-module ((guix utils) #:select (call-with-temporary-directory))
23 #:use-module ((guix build utils) #:select (substitute*))
24 #:use-module (guix diagnostics)
25 #:use-module (gnu packages acl)
26 #:use-module (gnu packages multiprecision)
27 #:use-module (srfi srfi-1)
28 #:use-module (srfi srfi-64)
29 #:use-module (ice-9 match)
30 #:use-module (ice-9 rdelim)
31 #:use-module (ice-9 pretty-print))
33 (define (call-with-test-package inputs proc)
34 (call-with-temporary-directory
36 (call-with-output-file (string-append directory "/my-packages.scm")
40 (define-module (my-packages)
42 #:use-module (guix licenses)
43 #:use-module (gnu packages acl)
44 #:use-module (gnu packages base)
45 #:use-module (gnu packages multiprecision)
46 #:use-module (srfi srfi-1))
53 (propagated-inputs '())))
55 (define (sdl-union . lst)
60 (define-public my-coreutils
64 (name "my-coreutils"))))
69 (define test-directory
70 ;; Directory where the package definition lives.
73 (define-syntax-rule (with-test-package fields exp ...)
74 (call-with-test-package fields
77 (string-append directory "/my-packages.scm"))
79 ;; Run as a separate process to make sure FILE is reloaded.
80 (system* "guix" "style" "-L" directory "my-coreutils")
84 (parameterize ((test-directory directory))
87 (define* (read-lines port line #:optional (count 1))
88 "Read COUNT lines from PORT, starting from LINE."
89 (let loop ((lines '())
91 (cond ((< (port-line port) (- line 1))
95 (string-concatenate-reverse lines))
97 (match (read-line port 'concat)
101 (loop (cons line lines) (- count 1))))))))
103 (define* (read-package-field package field #:optional (count 1))
104 (let* ((location (package-field-location package field))
105 (file (location-file location))
106 (line (location-line location)))
107 (call-with-input-file (if (string-prefix? "/" file)
109 (string-append (test-directory) "/"
112 (read-lines port line count)))))
117 (test-equal "nothing to rewrite"
119 (with-test-package '()
120 (package-direct-inputs (@ (my-packages) my-coreutils))))
122 (test-equal "input labels, mismatch"
123 (list `(("foo" ,gmp) ("bar" ,acl))
124 " (inputs `((\"foo\" ,gmp) (\"bar\" ,acl)))\n")
125 (with-test-package '((inputs `(("foo" ,gmp) ("bar" ,acl))))
126 (list (package-direct-inputs (@ (my-packages) my-coreutils))
127 (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
129 (test-equal "input labels, simple"
130 (list `(("gmp" ,gmp) ("acl" ,acl))
131 " (inputs (list gmp acl))\n")
132 (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
133 (list (package-direct-inputs (@ (my-packages) my-coreutils))
134 (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
136 (test-equal "input labels, long list with one item per line"
137 (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
147 (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
148 ("gmp" ,gmp) ("acl" ,acl)
149 ("gmp" ,gmp) ("acl" ,acl)
150 ("gmp" ,gmp) ("acl" ,acl))))
151 (list (package-direct-inputs (@ (my-packages) my-coreutils))
152 (read-package-field (@ (my-packages) my-coreutils) 'inputs 8))))
154 (test-equal "input labels, sdl-union"
157 (sdl-union 1 2 3 4)))\n"
158 (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
159 ("sdl-union" ,(sdl-union 1 2 3 4)))))
160 (read-package-field (@ (my-packages) my-coreutils) 'inputs 2)))
162 (test-equal "input labels, output"
163 (list `(("gmp" ,gmp "debug") ("acl" ,acl))
164 " (inputs (list `(,gmp \"debug\") acl))\n")
165 (with-test-package '((inputs `(("gmp" ,gmp "debug") ("acl" ,acl))))
166 (list (package-direct-inputs (@ (my-packages) my-coreutils))
167 (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
169 (test-equal "input labels, prepend"
170 (list `(("gmp" ,gmp) ("acl" ,acl))
172 (modify-inputs (package-propagated-inputs coreutils)
173 (prepend gmp acl)))\n")
174 (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
175 ,@(package-propagated-inputs coreutils))))
176 (list (package-inputs (@ (my-packages) my-coreutils))
177 (read-package-field (@ (my-packages) my-coreutils) 'inputs 2))))
179 (test-equal "input labels, prepend + delete"
180 (list `(("gmp" ,gmp) ("acl" ,acl))
182 (modify-inputs (package-propagated-inputs coreutils)
184 (prepend gmp acl)))\n")
185 (with-test-package '((inputs `(("gmp" ,gmp)
187 ,@(alist-delete "gmp"
188 (package-propagated-inputs coreutils)))))
189 (list (package-inputs (@ (my-packages) my-coreutils))
190 (read-package-field (@ (my-packages) my-coreutils) 'inputs 3))))
192 (test-equal "input labels, prepend + delete multiple"
193 (list `(("gmp" ,gmp) ("acl" ,acl))
195 (modify-inputs (package-propagated-inputs coreutils)
196 (delete \"foo\" \"bar\" \"baz\")
197 (prepend gmp acl)))\n")
198 (with-test-package '((inputs `(("gmp" ,gmp)
201 (package-propagated-inputs coreutils)
202 '("foo" "bar" "baz")))))
203 (list (package-inputs (@ (my-packages) my-coreutils))
204 (read-package-field (@ (my-packages) my-coreutils) 'inputs 3))))
206 (test-equal "input labels, replace"
207 (list '() ;there's no "gmp" input to replace
209 (modify-inputs (package-propagated-inputs coreutils)
210 (replace \"gmp\" gmp)))\n")
211 (with-test-package '((inputs `(("gmp" ,gmp)
212 ,@(alist-delete "gmp"
213 (package-propagated-inputs coreutils)))))
214 (list (package-inputs (@ (my-packages) my-coreutils))
215 (read-package-field (@ (my-packages) my-coreutils) 'inputs 2))))
217 (test-equal "input labels, 'safe' policy"
218 (list `(("gmp" ,gmp) ("acl" ,acl))
220 (inputs (list gmp acl))\n")
221 (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))
222 (arguments '())) ;no build system arguments
225 (string-append directory "/my-packages.scm"))
227 (system* "guix" "style" "-L" directory "my-coreutils"
228 "--input-simplification=safe")
231 (list (package-inputs (@ (my-packages) my-coreutils))
232 (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
234 (test-equal "input labels, 'safe' policy, nothing changed"
235 (list `(("GMP" ,gmp) ("ACL" ,acl))
237 (inputs `((\"GMP\" ,gmp) (\"ACL\" ,acl)))\n")
238 (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))
239 ;; Non-empty argument list, so potentially unsafe
240 ;; input simplification.
243 (assoc-ref %build-inputs "GMP"))))
246 (string-append directory "/my-packages.scm"))
248 (system* "guix" "style" "-L" directory "my-coreutils"
249 "--input-simplification=safe")
252 (list (package-inputs (@ (my-packages) my-coreutils))
253 (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
255 (test-equal "input labels, margin comment"
256 (list `(("gmp" ,gmp))
258 " (inputs (list gmp)) ;margin comment\n"
259 " (native-inputs (list acl)) ;another one\n")
260 (call-with-test-package '((inputs `(("gmp" ,gmp)))
261 (native-inputs `(("acl" ,acl))))
264 (string-append directory "/my-packages.scm"))
267 (("\"gmp\"(.*)$" _ rest)
268 (string-append "\"gmp\"" (string-trim-right rest)
269 " ;margin comment\n"))
270 (("\"acl\"(.*)$" _ rest)
271 (string-append "\"acl\"" (string-trim-right rest)
275 (system* "guix" "style" "-L" directory "my-coreutils")
278 (list (package-inputs (@ (my-packages) my-coreutils))
279 (package-native-inputs (@ (my-packages) my-coreutils))
280 (read-package-field (@ (my-packages) my-coreutils) 'inputs)
281 (read-package-field (@ (my-packages) my-coreutils) 'native-inputs)))))
283 (test-equal "input labels, margin comment on long list"
284 (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
286 (list gmp ;margin comment
294 (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
295 ("gmp" ,gmp) ("acl" ,acl)
296 ("gmp" ,gmp) ("acl" ,acl)
297 ("gmp" ,gmp) ("acl" ,acl))))
300 (string-append directory "/my-packages.scm"))
303 (("\"gmp\"(.*)$" _ rest)
304 (string-append "\"gmp\"" (string-trim-right rest)
305 " ;margin comment\n")))
308 (system* "guix" "style" "-L" directory "my-coreutils")
311 (list (package-inputs (@ (my-packages) my-coreutils))
312 (read-package-field (@ (my-packages) my-coreutils) 'inputs 8)))))
314 (test-equal "input labels, line comment"
315 (list `(("gmp" ,gmp) ("acl" ,acl))
320 (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
323 (string-append directory "/my-packages.scm"))
326 ((",gmp\\)(.*)$" _ rest)
327 (string-append ",gmp)\n ;; line comment!\n" rest)))
329 (system* "guix" "style" "-L" directory "my-coreutils")
332 (list (package-inputs (@ (my-packages) my-coreutils))
333 (read-package-field (@ (my-packages) my-coreutils) 'inputs 3)))))
335 (test-equal "input labels, modify-inputs and margin comment"
336 (list `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr))
338 (modify-inputs (package-propagated-inputs coreutils)
339 (prepend gmp ;margin comment
342 (call-with-test-package '((inputs
343 `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr)
344 ,@(package-propagated-inputs coreutils))))
347 (string-append directory "/my-packages.scm"))
350 ((",gmp\\)(.*)$" _ rest)
351 (string-append ",gmp) ;margin comment\n" rest))
352 ((",acl\\)(.*)$" _ rest)
353 (string-append ",acl) ;another one\n" rest)))
355 (system* "guix" "style" "-L" directory "my-coreutils")
358 (list (package-inputs (@ (my-packages) my-coreutils))
359 (read-package-field (@ (my-packages) my-coreutils) 'inputs 4)))))
364 ;; eval: (put 'with-test-package 'scheme-indent-function 1)
365 ;; eval: (put 'call-with-test-package 'scheme-indent-function 1)