tests/style.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   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.
  10 ;;;
  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.
  15 ;;;
  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/>.
  18
  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))
  33
  34 (define (call-with-test-package inputs proc)
  35   (call-with-temporary-directory
  36    (lambda (directory)
  37      (call-with-output-file (string-append directory "/my-packages.scm")
  38        (lambda (port)
  39          (pretty-print
  40           `(begin
  41              (define-module (my-packages)
  42                #:use-module (guix)
  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))
  48
  49              (define base
  50                (package
  51                  (inherit coreutils)
  52                  (inputs '())
  53                  (native-inputs '())
  54                  (propagated-inputs '())))
  55
  56              (define (sdl-union . lst)
  57                (package
  58                  (inherit base)
  59                  (name "sdl-union")))
  60
  61              (define-public my-coreutils
  62                (package
  63                  (inherit base)
  64                  ,@inputs
  65                  (name "my-coreutils"))))
  66           port)))
  67
  68      (proc directory))))
  69
  70 (define test-directory
  71   ;; Directory where the package definition lives.
  72   (make-parameter #f))
  73
  74 (define-syntax-rule (with-test-package fields exp ...)
  75   (call-with-test-package fields
  76     (lambda (directory)
  77       (define file
  78         (string-append directory "/my-packages.scm"))
  79
  80       ;; Run as a separate process to make sure FILE is reloaded.
  81       (system* "guix" "style" "-L" directory "-S" "inputs"
  82                "my-coreutils")
  83       (system* "cat" file)
  84
  85       (load file)
  86       (parameterize ((test-directory directory))
  87         exp ...))))
  88
  89 (define* (read-lines port line #:optional (count 1))
  90   "Read COUNT lines from PORT, starting from LINE."
  91   (let loop ((lines '())
  92              (count count))
  93     (cond ((< (port-line port) (- line 1))
  94            (read-char port)
  95            (loop lines count))
  96           ((zero? count)
  97            (string-concatenate-reverse lines))
  98           (else
  99            (match (read-line port 'concat)
 100              ((? eof-object?)
 101               (loop lines 0))
 102              (line
 103               (loop (cons line lines) (- count 1))))))))
 104
 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)
 110                               file
 111                               (string-append (test-directory) "/"
 112                                              file))
 113       (lambda (port)
 114         (read-lines port line count)))))
 115
 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'."
 120   (test-equal str
 121     (call-with-output-string
 122       (lambda (port)
 123         (let ((exp (call-with-input-string str
 124                      read-with-comments)))
 125          (pretty-print-with-comments port exp args ...))))))
 126
 127 \f
 128 (test-begin "style")
 129
 130 (test-equal "nothing to rewrite"
 131   '()
 132   (with-test-package '()
 133     (package-direct-inputs (@ (my-packages) my-coreutils))))
 134
 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))))
 141
 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))))
 148
 149 (test-equal "input labels, long list with one item per line"
 150   (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
 151         "\
 152         (list gmp
 153               acl
 154               gmp
 155               acl
 156               gmp
 157               acl
 158               gmp
 159               acl))\n")
 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))))
 166
 167 (test-equal "input labels, sdl-union"
 168   "\
 169         (list gmp acl
 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)))
 174
 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))))
 181
 182 (test-equal "input labels, prepend"
 183   (list `(("gmp" ,gmp) ("acl" ,acl))
 184         "\
 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))))
 191
 192 (test-equal "input labels, prepend + delete"
 193   (list `(("gmp" ,gmp) ("acl" ,acl))
 194         "\
 195         (modify-inputs (package-propagated-inputs coreutils)
 196           (delete \"gmp\")
 197           (prepend gmp acl)))\n")
 198   (with-test-package '((inputs `(("gmp" ,gmp)
 199                                  ("acl" ,acl)
 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))))
 204
 205 (test-equal "input labels, prepend + delete multiple"
 206   (list `(("gmp" ,gmp) ("acl" ,acl))
 207         "\
 208         (modify-inputs (package-propagated-inputs coreutils)
 209           (delete \"foo\" \"bar\" \"baz\")
 210           (prepend gmp acl)))\n")
 211   (with-test-package '((inputs `(("gmp" ,gmp)
 212                                  ("acl" ,acl)
 213                                  ,@(fold alist-delete
 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))))
 218
 219 (test-equal "input labels, replace"
 220   (list '()                                 ;there's no "gmp" input to replace
 221         "\
 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))))
 229
 230 (test-equal "input labels, 'safe' policy"
 231   (list `(("gmp" ,gmp) ("acl" ,acl))
 232         "\
 233       (inputs (list gmp acl))\n")
 234   (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))
 235                             (arguments '()))      ;no build system arguments
 236     (lambda (directory)
 237       (define file
 238         (string-append directory "/my-packages.scm"))
 239
 240       (system* "guix" "style" "-L" directory "my-coreutils"
 241                "-S" "inputs"
 242                "--input-simplification=safe")
 243
 244       (load file)
 245       (list (package-inputs (@ (my-packages) my-coreutils))
 246             (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
 247
 248 (test-equal "input labels, 'safe' policy, nothing changed"
 249   (list `(("GMP" ,gmp) ("ACL" ,acl))
 250         "\
 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.
 255                             (arguments
 256                              '(#:configure-flags
 257                                (assoc-ref %build-inputs "GMP"))))
 258     (lambda (directory)
 259       (define file
 260         (string-append directory "/my-packages.scm"))
 261
 262       (system* "guix" "style" "-L" directory "my-coreutils"
 263                "-S" "inputs"
 264                "--input-simplification=safe")
 265
 266       (load file)
 267       (list (package-inputs (@ (my-packages) my-coreutils))
 268             (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
 269
 270 (test-equal "input labels, margin comment"
 271   (list `(("gmp" ,gmp))
 272         `(("acl" ,acl))
 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))))
 277     (lambda (directory)
 278       (define file
 279         (string-append directory "/my-packages.scm"))
 280
 281       (substitute* file
 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)
 287                         " ;another one\n")))
 288       (system* "cat" file)
 289
 290       (system* "guix" "style" "-L" directory "-S" "inputs"
 291                "my-coreutils")
 292
 293       (load file)
 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)))))
 298
 299 (test-equal "input labels, margin comment on long list"
 300   (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
 301         "\
 302         (list gmp ;margin comment
 303               acl
 304               gmp ;margin comment
 305               acl
 306               gmp ;margin comment
 307               acl
 308               gmp ;margin comment
 309               acl))\n")
 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))))
 314     (lambda (directory)
 315       (define file
 316         (string-append directory "/my-packages.scm"))
 317
 318       (substitute* file
 319         (("\"gmp\"(.*)$" _ rest)
 320          (string-append "\"gmp\"" (string-trim-right rest)
 321                         " ;margin comment\n")))
 322       (system* "cat" file)
 323
 324       (system* "guix" "style" "-L" directory "-S" "inputs"
 325                "my-coreutils")
 326
 327       (load file)
 328       (list (package-inputs (@ (my-packages) my-coreutils))
 329             (read-package-field (@ (my-packages) my-coreutils) 'inputs 8)))))
 330
 331 (test-equal "input labels, line comment"
 332   (list `(("gmp" ,gmp) ("acl" ,acl))
 333         "\
 334       (inputs (list gmp
 335                     ;; line comment!
 336                     acl))\n")
 337   (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
 338     (lambda (directory)
 339       (define file
 340         (string-append directory "/my-packages.scm"))
 341
 342       (substitute* file
 343         ((",gmp\\)(.*)$" _ rest)
 344          (string-append ",gmp)\n   ;; line comment!\n" rest)))
 345
 346       (system* "guix" "style" "-L" directory "-S" "inputs"
 347                "my-coreutils")
 348
 349       (load file)
 350       (list (package-inputs (@ (my-packages) my-coreutils))
 351             (read-package-field (@ (my-packages) my-coreutils) 'inputs 3)))))
 352
 353 (test-equal "input labels, modify-inputs and margin comment"
 354   (list `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr))
 355         "\
 356         (modify-inputs (package-propagated-inputs coreutils)
 357           (prepend gmp ;margin comment
 358                    acl ;another one
 359                    mpfr)))\n")
 360   (call-with-test-package '((inputs
 361                              `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr)
 362                                ,@(package-propagated-inputs coreutils))))
 363     (lambda (directory)
 364       (define file
 365         (string-append directory "/my-packages.scm"))
 366
 367       (substitute* file
 368         ((",gmp\\)(.*)$" _ rest)
 369          (string-append ",gmp) ;margin comment\n" rest))
 370         ((",acl\\)(.*)$" _ rest)
 371          (string-append ",acl) ;another one\n" rest)))
 372
 373       (system* "guix" "style" "-L" directory "-S" "inputs"
 374                "my-coreutils")
 375
 376       (load file)
 377       (list (package-inputs (@ (my-packages) my-coreutils))
 378             (read-package-field (@ (my-packages) my-coreutils) 'inputs 4)))))
 379
 380 (test-equal "read-with-comments: dot notation"
 381   (cons 'a 'b)
 382   (call-with-input-string "(a . b)"
 383     read-with-comments))
 384
 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
 389                           2
 390                           3
 391                           4)"
 392                    #:long-list 3
 393                    #:indent 20)
 394 (test-pretty-print "\
 395 (list abc
 396       def)"
 397                    #:max-width 11)
 398 (test-pretty-print "\
 399 (#:foo
 400  #:bar)"
 401                    #:max-width 10)
 402
 403 (test-pretty-print "\
 404 (#:first 1
 405  #:second 2
 406  #:third 3)")
 407
 408 (test-pretty-print "\
 409 ((x
 410   1)
 411  (y
 412   2)
 413  (z
 414   3))"
 415                    #:max-width 3)
 416
 417 (test-pretty-print "\
 418 (let ((x 1)
 419       (y 2)
 420       (z 3)
 421       (p 4))
 422   (+ x y))"
 423                    #:max-width 11)
 424
 425 (test-pretty-print "\
 426 (lambda (x y)
 427   ;; This is a procedure.
 428   (let ((z (+ x y)))
 429     (* z z)))")
 430
 431 (test-pretty-print "\
 432 #~(string-append #$coreutils \"/bin/uname\")")
 433
 434 (test-pretty-print "\
 435 (package
 436   (inherit coreutils)
 437   (version \"42\"))")
 438
 439 (test-pretty-print "\
 440 (modify-phases %standard-phases
 441   (add-after 'unpack 'post-unpack
 442     (lambda _
 443       #t))
 444   (add-before 'check 'pre-check
 445     (lambda* (#:key inputs #:allow-other-keys)
 446       do things ...)))")
 447
 448 (test-pretty-print "\
 449 (#:phases (modify-phases sdfsdf
 450             (add-before 'x 'y
 451               (lambda _
 452                 xyz))))")
 453
 454 (test-pretty-print "\
 455 (description \"abcdefghijkl
 456 mnopqrstuvwxyz.\")"
 457                    #:max-width 30)
 458
 459 (test-pretty-print "\
 460 (description
 461  \"abcdefghijkl
 462 mnopqrstuvwxyz.\")"
 463                    #:max-width 12)
 464
 465 (test-pretty-print "\
 466 (description
 467  \"abcdefghijklmnopqrstuvwxyz\")"
 468                    #:max-width 33)
 469
 470 (test-pretty-print "\
 471 (modify-phases %standard-phases
 472   (replace 'build
 473     ;; Nicely indented in 'modify-phases' context.
 474     (lambda _
 475       #t)))")
 476
 477 (test-pretty-print "\
 478 (modify-inputs inputs
 479   ;; Regular indentation for 'replace' here.
 480   (replace \"gmp\" gmp))")
 481
 482 (test-pretty-print "\
 483 (package
 484   ;; Here 'sha256', 'base32', and 'arguments' must be
 485   ;; immediately followed by a newline.
 486   (source (origin
 487             (method url-fetch)
 488             (sha256
 489              (base32
 490               \"not a real base32 string\"))))
 491   (arguments
 492    '(#:phases %standard-phases
 493      #:tests? #f)))")
 494
 495 (test-equal "pretty-print-with-comments, canonicalize-comment"
 496   "\
 497 (list abc
 498       ;; Not a margin comment.
 499       ;; Ditto.
 500       ;;
 501       ;; There's a blank line above.
 502       def ;margin comment
 503       ghi)"
 504   (let ((sexp (call-with-input-string
 505                   "\
 506 (list abc
 507   ;Not a margin comment.
 508   ;;;  Ditto.
 509   ;;;;;
 510   ; There's a blank line above.
 511   def  ;; margin comment
 512   ghi)"
 513                 read-with-comments)))
 514     (call-with-output-string
 515       (lambda (port)
 516         (pretty-print-with-comments port sexp
 517                                     #:format-comment
 518                                     canonicalize-comment)))))
 519
 520 (test-end)
 521
 522 ;; Local Variables:
 523 ;; eval: (put 'with-test-package 'scheme-indent-function 1)
 524 ;; eval: (put 'call-with-test-package 'scheme-indent-function 1)
 525 ;; End: