1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2021-2022 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 gexp) ;for the reader extension
25 #:use-module (guix diagnostics)
26 #:use-module (gnu packages acl)
27 #:use-module (gnu packages multiprecision)
28 #:use-module (srfi srfi-1)
29 #:use-module (srfi srfi-64)
30 #:use-module (ice-9 match)
31 #:use-module (ice-9 rdelim)
32 #:use-module (ice-9 pretty-print))
34 (define (call-with-test-package inputs proc)
35 (call-with-temporary-directory
37 (call-with-output-file (string-append directory "/my-packages.scm")
41 (define-module (my-packages)
43 #:use-module (guix licenses)
44 #:use-module (gnu packages acl)
45 #:use-module (gnu packages base)
46 #:use-module (gnu packages multiprecision)
47 #:use-module (srfi srfi-1))
54 (propagated-inputs '())))
56 (define (sdl-union . lst)
61 (define-public my-coreutils
65 (name "my-coreutils"))))
70 (define test-directory
71 ;; Directory where the package definition lives.
74 (define-syntax-rule (with-test-package fields exp ...)
75 (call-with-test-package fields
78 (string-append directory "/my-packages.scm"))
80 ;; Run as a separate process to make sure FILE is reloaded.
81 (system* "guix" "style" "-L" directory "-S" "inputs"
86 (parameterize ((test-directory directory))
89 (define* (read-lines port line #:optional (count 1))
90 "Read COUNT lines from PORT, starting from LINE."
91 (let loop ((lines '())
93 (cond ((< (port-line port) (- line 1))
97 (string-concatenate-reverse lines))
99 (match (read-line port 'concat)
103 (loop (cons line lines) (- count 1))))))))
105 (define* (read-package-field package field #:optional (count 1))
106 (let* ((location (package-field-location package field))
107 (file (location-file location))
108 (line (location-line location)))
109 (call-with-input-file (if (string-prefix? "/" file)
111 (string-append (test-directory) "/"
114 (read-lines port line count)))))
119 (test-equal "nothing to rewrite"
121 (with-test-package '()
122 (package-direct-inputs (@ (my-packages) my-coreutils))))
124 (test-equal "input labels, mismatch"
125 (list `(("foo" ,gmp) ("bar" ,acl))
126 " (inputs `((\"foo\" ,gmp) (\"bar\" ,acl)))\n")
127 (with-test-package '((inputs `(("foo" ,gmp) ("bar" ,acl))))
128 (list (package-direct-inputs (@ (my-packages) my-coreutils))
129 (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
131 (test-equal "input labels, simple"
132 (list `(("gmp" ,gmp) ("acl" ,acl))
133 " (inputs (list gmp acl))\n")
134 (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
135 (list (package-direct-inputs (@ (my-packages) my-coreutils))
136 (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
138 (test-equal "input labels, long list with one item per line"
139 (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
149 (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
150 ("gmp" ,gmp) ("acl" ,acl)
151 ("gmp" ,gmp) ("acl" ,acl)
152 ("gmp" ,gmp) ("acl" ,acl))))
153 (list (package-direct-inputs (@ (my-packages) my-coreutils))
154 (read-package-field (@ (my-packages) my-coreutils) 'inputs 8))))
156 (test-equal "input labels, sdl-union"
159 (sdl-union 1 2 3 4)))\n"
160 (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
161 ("sdl-union" ,(sdl-union 1 2 3 4)))))
162 (read-package-field (@ (my-packages) my-coreutils) 'inputs 2)))
164 (test-equal "input labels, output"
165 (list `(("gmp" ,gmp "debug") ("acl" ,acl))
166 " (inputs (list `(,gmp \"debug\") acl))\n")
167 (with-test-package '((inputs `(("gmp" ,gmp "debug") ("acl" ,acl))))
168 (list (package-direct-inputs (@ (my-packages) my-coreutils))
169 (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
171 (test-equal "input labels, prepend"
172 (list `(("gmp" ,gmp) ("acl" ,acl))
174 (modify-inputs (package-propagated-inputs coreutils)
175 (prepend gmp acl)))\n")
176 (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
177 ,@(package-propagated-inputs coreutils))))
178 (list (package-inputs (@ (my-packages) my-coreutils))
179 (read-package-field (@ (my-packages) my-coreutils) 'inputs 2))))
181 (test-equal "input labels, prepend + delete"
182 (list `(("gmp" ,gmp) ("acl" ,acl))
184 (modify-inputs (package-propagated-inputs coreutils)
186 (prepend gmp acl)))\n")
187 (with-test-package '((inputs `(("gmp" ,gmp)
189 ,@(alist-delete "gmp"
190 (package-propagated-inputs coreutils)))))
191 (list (package-inputs (@ (my-packages) my-coreutils))
192 (read-package-field (@ (my-packages) my-coreutils) 'inputs 3))))
194 (test-equal "input labels, prepend + delete multiple"
195 (list `(("gmp" ,gmp) ("acl" ,acl))
197 (modify-inputs (package-propagated-inputs coreutils)
198 (delete \"foo\" \"bar\" \"baz\")
199 (prepend gmp acl)))\n")
200 (with-test-package '((inputs `(("gmp" ,gmp)
203 (package-propagated-inputs coreutils)
204 '("foo" "bar" "baz")))))
205 (list (package-inputs (@ (my-packages) my-coreutils))
206 (read-package-field (@ (my-packages) my-coreutils) 'inputs 3))))
208 (test-equal "input labels, replace"
209 (list '() ;there's no "gmp" input to replace
211 (modify-inputs (package-propagated-inputs coreutils)
212 (replace \"gmp\" gmp)))\n")
213 (with-test-package '((inputs `(("gmp" ,gmp)
214 ,@(alist-delete "gmp"
215 (package-propagated-inputs coreutils)))))
216 (list (package-inputs (@ (my-packages) my-coreutils))
217 (read-package-field (@ (my-packages) my-coreutils) 'inputs 2))))
219 (test-equal "input labels, 'safe' policy"
220 (list `(("gmp" ,gmp) ("acl" ,acl))
222 (inputs (list gmp acl))\n")
223 (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))
224 (arguments '())) ;no build system arguments
227 (string-append directory "/my-packages.scm"))
229 (system* "guix" "style" "-L" directory "my-coreutils"
231 "--input-simplification=safe")
234 (list (package-inputs (@ (my-packages) my-coreutils))
235 (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
237 (test-equal "input labels, 'safe' policy, nothing changed"
238 (list `(("GMP" ,gmp) ("ACL" ,acl))
240 (inputs `((\"GMP\" ,gmp) (\"ACL\" ,acl)))\n")
241 (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))
242 ;; Non-empty argument list, so potentially unsafe
243 ;; input simplification.
246 (assoc-ref %build-inputs "GMP"))))
249 (string-append directory "/my-packages.scm"))
251 (system* "guix" "style" "-L" directory "my-coreutils"
253 "--input-simplification=safe")
256 (list (package-inputs (@ (my-packages) my-coreutils))
257 (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
259 (test-equal "input labels, margin comment"
260 (list `(("gmp" ,gmp))
262 " (inputs (list gmp)) ;margin comment\n"
263 " (native-inputs (list acl)) ;another one\n")
264 (call-with-test-package '((inputs `(("gmp" ,gmp)))
265 (native-inputs `(("acl" ,acl))))
268 (string-append directory "/my-packages.scm"))
271 (("\"gmp\"(.*)$" _ rest)
272 (string-append "\"gmp\"" (string-trim-right rest)
273 " ;margin comment\n"))
274 (("\"acl\"(.*)$" _ rest)
275 (string-append "\"acl\"" (string-trim-right rest)
279 (system* "guix" "style" "-L" directory "-S" "inputs"
283 (list (package-inputs (@ (my-packages) my-coreutils))
284 (package-native-inputs (@ (my-packages) my-coreutils))
285 (read-package-field (@ (my-packages) my-coreutils) 'inputs)
286 (read-package-field (@ (my-packages) my-coreutils) 'native-inputs)))))
288 (test-equal "input labels, margin comment on long list"
289 (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
291 (list gmp ;margin comment
299 (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
300 ("gmp" ,gmp) ("acl" ,acl)
301 ("gmp" ,gmp) ("acl" ,acl)
302 ("gmp" ,gmp) ("acl" ,acl))))
305 (string-append directory "/my-packages.scm"))
308 (("\"gmp\"(.*)$" _ rest)
309 (string-append "\"gmp\"" (string-trim-right rest)
310 " ;margin comment\n")))
313 (system* "guix" "style" "-L" directory "-S" "inputs"
317 (list (package-inputs (@ (my-packages) my-coreutils))
318 (read-package-field (@ (my-packages) my-coreutils) 'inputs 8)))))
320 (test-equal "input labels, line comment"
321 (list `(("gmp" ,gmp) ("acl" ,acl))
326 (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
329 (string-append directory "/my-packages.scm"))
332 ((",gmp\\)(.*)$" _ rest)
333 (string-append ",gmp)\n ;; line comment!\n" rest)))
335 (system* "guix" "style" "-L" directory "-S" "inputs"
339 (list (package-inputs (@ (my-packages) my-coreutils))
340 (read-package-field (@ (my-packages) my-coreutils) 'inputs 3)))))
342 (test-equal "input labels, modify-inputs and margin comment"
343 (list `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr))
345 (modify-inputs (package-propagated-inputs coreutils)
346 (prepend gmp ;margin comment
349 (call-with-test-package '((inputs
350 `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr)
351 ,@(package-propagated-inputs coreutils))))
354 (string-append directory "/my-packages.scm"))
357 ((",gmp\\)(.*)$" _ rest)
358 (string-append ",gmp) ;margin comment" rest))
359 ((",acl\\)(.*)$" _ rest)
360 (string-append ",acl) ;another one" rest)))
362 (system* "guix" "style" "-L" directory "-S" "inputs"
366 (list (package-inputs (@ (my-packages) my-coreutils))
367 (read-package-field (@ (my-packages) my-coreutils) 'inputs 4)))))
373 ;; eval: (put 'with-test-package 'scheme-indent-function 1)
374 ;; eval: (put 'call-with-test-package 'scheme-indent-function 1)