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)))))
116 (define-syntax-rule (test-pretty-print str args ...)
117 "Test equality after a round-trip where STR is passed to
118 'read-with-comments' and the resulting sexp is then passed to
119 'pretty-print-with-comments'."
121 (call-with-output-string
123 (let ((exp (call-with-input-string str
124 read-with-comments)))
125 (pretty-print-with-comments port exp args ...))))))
130 (test-equal "nothing to rewrite"
132 (with-test-package '()
133 (package-direct-inputs (@ (my-packages) my-coreutils))))
135 (test-equal "input labels, mismatch"
136 (list `(("foo" ,gmp) ("bar" ,acl))
137 " (inputs `((\"foo\" ,gmp) (\"bar\" ,acl)))\n")
138 (with-test-package '((inputs `(("foo" ,gmp) ("bar" ,acl))))
139 (list (package-direct-inputs (@ (my-packages) my-coreutils))
140 (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
142 (test-equal "input labels, simple"
143 (list `(("gmp" ,gmp) ("acl" ,acl))
144 " (inputs (list gmp acl))\n")
145 (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
146 (list (package-direct-inputs (@ (my-packages) my-coreutils))
147 (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
149 (test-equal "input labels, long list with one item per line"
150 (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
160 (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
161 ("gmp" ,gmp) ("acl" ,acl)
162 ("gmp" ,gmp) ("acl" ,acl)
163 ("gmp" ,gmp) ("acl" ,acl))))
164 (list (package-direct-inputs (@ (my-packages) my-coreutils))
165 (read-package-field (@ (my-packages) my-coreutils) 'inputs 8))))
167 (test-equal "input labels, sdl-union"
170 (sdl-union 1 2 3 4)))\n"
171 (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
172 ("sdl-union" ,(sdl-union 1 2 3 4)))))
173 (read-package-field (@ (my-packages) my-coreutils) 'inputs 2)))
175 (test-equal "input labels, output"
176 (list `(("gmp" ,gmp "debug") ("acl" ,acl))
177 " (inputs (list `(,gmp \"debug\") acl))\n")
178 (with-test-package '((inputs `(("gmp" ,gmp "debug") ("acl" ,acl))))
179 (list (package-direct-inputs (@ (my-packages) my-coreutils))
180 (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
182 (test-equal "input labels, prepend"
183 (list `(("gmp" ,gmp) ("acl" ,acl))
185 (modify-inputs (package-propagated-inputs coreutils)
186 (prepend gmp acl)))\n")
187 (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
188 ,@(package-propagated-inputs coreutils))))
189 (list (package-inputs (@ (my-packages) my-coreutils))
190 (read-package-field (@ (my-packages) my-coreutils) 'inputs 2))))
192 (test-equal "input labels, prepend + delete"
193 (list `(("gmp" ,gmp) ("acl" ,acl))
195 (modify-inputs (package-propagated-inputs coreutils)
197 (prepend gmp acl)))\n")
198 (with-test-package '((inputs `(("gmp" ,gmp)
200 ,@(alist-delete "gmp"
201 (package-propagated-inputs coreutils)))))
202 (list (package-inputs (@ (my-packages) my-coreutils))
203 (read-package-field (@ (my-packages) my-coreutils) 'inputs 3))))
205 (test-equal "input labels, prepend + delete multiple"
206 (list `(("gmp" ,gmp) ("acl" ,acl))
208 (modify-inputs (package-propagated-inputs coreutils)
209 (delete \"foo\" \"bar\" \"baz\")
210 (prepend gmp acl)))\n")
211 (with-test-package '((inputs `(("gmp" ,gmp)
214 (package-propagated-inputs coreutils)
215 '("foo" "bar" "baz")))))
216 (list (package-inputs (@ (my-packages) my-coreutils))
217 (read-package-field (@ (my-packages) my-coreutils) 'inputs 3))))
219 (test-equal "input labels, replace"
220 (list '() ;there's no "gmp" input to replace
222 (modify-inputs (package-propagated-inputs coreutils)
223 (replace \"gmp\" gmp)))\n")
224 (with-test-package '((inputs `(("gmp" ,gmp)
225 ,@(alist-delete "gmp"
226 (package-propagated-inputs coreutils)))))
227 (list (package-inputs (@ (my-packages) my-coreutils))
228 (read-package-field (@ (my-packages) my-coreutils) 'inputs 2))))
230 (test-equal "input labels, 'safe' policy"
231 (list `(("gmp" ,gmp) ("acl" ,acl))
233 (inputs (list gmp acl))\n")
234 (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))
235 (arguments '())) ;no build system arguments
238 (string-append directory "/my-packages.scm"))
240 (system* "guix" "style" "-L" directory "my-coreutils"
242 "--input-simplification=safe")
245 (list (package-inputs (@ (my-packages) my-coreutils))
246 (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
248 (test-equal "input labels, 'safe' policy, nothing changed"
249 (list `(("GMP" ,gmp) ("ACL" ,acl))
251 (inputs `((\"GMP\" ,gmp) (\"ACL\" ,acl)))\n")
252 (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))
253 ;; Non-empty argument list, so potentially unsafe
254 ;; input simplification.
257 (assoc-ref %build-inputs "GMP"))))
260 (string-append directory "/my-packages.scm"))
262 (system* "guix" "style" "-L" directory "my-coreutils"
264 "--input-simplification=safe")
267 (list (package-inputs (@ (my-packages) my-coreutils))
268 (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
270 (test-equal "input labels, margin comment"
271 (list `(("gmp" ,gmp))
273 " (inputs (list gmp)) ;margin comment\n"
274 " (native-inputs (list acl)) ;another one\n")
275 (call-with-test-package '((inputs `(("gmp" ,gmp)))
276 (native-inputs `(("acl" ,acl))))
279 (string-append directory "/my-packages.scm"))
282 (("\"gmp\"(.*)$" _ rest)
283 (string-append "\"gmp\"" (string-trim-right rest)
284 " ;margin comment\n"))
285 (("\"acl\"(.*)$" _ rest)
286 (string-append "\"acl\"" (string-trim-right rest)
290 (system* "guix" "style" "-L" directory "-S" "inputs"
294 (list (package-inputs (@ (my-packages) my-coreutils))
295 (package-native-inputs (@ (my-packages) my-coreutils))
296 (read-package-field (@ (my-packages) my-coreutils) 'inputs)
297 (read-package-field (@ (my-packages) my-coreutils) 'native-inputs)))))
299 (test-equal "input labels, margin comment on long list"
300 (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
302 (list gmp ;margin comment
310 (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
311 ("gmp" ,gmp) ("acl" ,acl)
312 ("gmp" ,gmp) ("acl" ,acl)
313 ("gmp" ,gmp) ("acl" ,acl))))
316 (string-append directory "/my-packages.scm"))
319 (("\"gmp\"(.*)$" _ rest)
320 (string-append "\"gmp\"" (string-trim-right rest)
321 " ;margin comment\n")))
324 (system* "guix" "style" "-L" directory "-S" "inputs"
328 (list (package-inputs (@ (my-packages) my-coreutils))
329 (read-package-field (@ (my-packages) my-coreutils) 'inputs 8)))))
331 (test-equal "input labels, line comment"
332 (list `(("gmp" ,gmp) ("acl" ,acl))
337 (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
340 (string-append directory "/my-packages.scm"))
343 ((",gmp\\)(.*)$" _ rest)
344 (string-append ",gmp)\n ;; line comment!\n" rest)))
346 (system* "guix" "style" "-L" directory "-S" "inputs"
350 (list (package-inputs (@ (my-packages) my-coreutils))
351 (read-package-field (@ (my-packages) my-coreutils) 'inputs 3)))))
353 (test-equal "input labels, modify-inputs and margin comment"
354 (list `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr))
356 (modify-inputs (package-propagated-inputs coreutils)
357 (prepend gmp ;margin comment
360 (call-with-test-package '((inputs
361 `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr)
362 ,@(package-propagated-inputs coreutils))))
365 (string-append directory "/my-packages.scm"))
368 ((",gmp\\)(.*)$" _ rest)
369 (string-append ",gmp) ;margin comment\n" rest))
370 ((",acl\\)(.*)$" _ rest)
371 (string-append ",acl) ;another one\n" rest)))
373 (system* "guix" "style" "-L" directory "-S" "inputs"
377 (list (package-inputs (@ (my-packages) my-coreutils))
378 (read-package-field (@ (my-packages) my-coreutils) 'inputs 4)))))
380 (test-equal "read-with-comments: dot notation"
382 (call-with-input-string "(a . b)"
385 (test-pretty-print "(list 1 2 3 4)")
386 (test-pretty-print "((a . 1) (b . 2))")
387 (test-pretty-print "(a b c . boom)")
388 (test-pretty-print "(list 1
394 (test-pretty-print "\
398 (test-pretty-print "\
403 (test-pretty-print "\
408 (test-pretty-print "\
417 (test-pretty-print "\
425 (test-pretty-print "\
427 ;; This is a procedure.
431 (test-pretty-print "\
432 #~(string-append #$coreutils \"/bin/uname\")")
434 (test-pretty-print "\
439 (test-pretty-print "\
440 (modify-phases %standard-phases
441 (add-after 'unpack 'post-unpack
444 (add-before 'check 'pre-check
445 (lambda* (#:key inputs #:allow-other-keys)
448 (test-pretty-print "\
449 (#:phases (modify-phases sdfsdf
454 (test-pretty-print "\
455 (description \"abcdefghijkl
459 (test-pretty-print "\
465 (test-pretty-print "\
467 \"abcdefghijklmnopqrstuvwxyz\")"
470 (test-pretty-print "\
471 (modify-phases %standard-phases
473 ;; Nicely indented in 'modify-phases' context.
477 (test-pretty-print "\
478 (modify-inputs inputs
479 ;; Regular indentation for 'replace' here.
480 (replace \"gmp\" gmp))")
482 (test-pretty-print "\
484 ;; Here 'sha256', 'base32', and 'arguments' must be
485 ;; immediately followed by a newline.
490 \"not a real base32 string\"))))
492 '(#:phases %standard-phases
495 ;; '#:key value' is kept on the same line.
496 (test-pretty-print "\
498 (name \"keyword-value-same-line\")
500 (list #:phases #~(modify-phases %standard-phases
502 (lambda* (#:key inputs #:allow-other-keys)
504 #:make-flags #~'(\"ANSWER=42\")
507 (test-equal "pretty-print-with-comments, canonicalize-comment"
510 ;; Not a margin comment.
513 ;; There's a blank line above.
516 (let ((sexp (call-with-input-string
519 ;Not a margin comment.
522 ; There's a blank line above.
523 def ;; margin comment
525 read-with-comments)))
526 (call-with-output-string
528 (pretty-print-with-comments port sexp
530 canonicalize-comment)))))
535 ;; eval: (put 'with-test-package 'scheme-indent-function 1)
536 ;; eval: (put 'call-with-test-package 'scheme-indent-function 1)