tests/style.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2021 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 "my-coreutils")
  82       (system* "cat" file)
  83
  84       (load file)
  85       (parameterize ((test-directory directory))
  86         exp ...))))
  87
  88 (define* (read-lines port line #:optional (count 1))
  89   "Read COUNT lines from PORT, starting from LINE."
  90   (let loop ((lines '())
  91              (count count))
  92     (cond ((< (port-line port) (- line 1))
  93            (read-char port)
  94            (loop lines count))
  95           ((zero? count)
  96            (string-concatenate-reverse lines))
  97           (else
  98            (match (read-line port 'concat)
  99              ((? eof-object?)
 100               (loop lines 0))
 101              (line
 102               (loop (cons line lines) (- count 1))))))))
 103
 104 (define* (read-package-field package field #:optional (count 1))
 105   (let* ((location (package-field-location package field))
 106          (file (location-file location))
 107          (line (location-line location)))
 108     (call-with-input-file (if (string-prefix? "/" file)
 109                               file
 110                               (string-append (test-directory) "/"
 111                                              file))
 112       (lambda (port)
 113         (read-lines port line count)))))
 114
 115 (define-syntax-rule (test-pretty-print str args ...)
 116   "Test equality after a round-trip where STR is passed to
 117 'read-with-comments' and the resulting sexp is then passed to
 118 'pretty-print-with-comments'."
 119   (test-equal str
 120     (call-with-output-string
 121       (lambda (port)
 122         (let ((exp (call-with-input-string str
 123                      read-with-comments)))
 124          (pretty-print-with-comments port exp args ...))))))
 125
 126 \f
 127 (test-begin "style")
 128
 129 (test-equal "nothing to rewrite"
 130   '()
 131   (with-test-package '()
 132     (package-direct-inputs (@ (my-packages) my-coreutils))))
 133
 134 (test-equal "input labels, mismatch"
 135   (list `(("foo" ,gmp) ("bar" ,acl))
 136         "      (inputs `((\"foo\" ,gmp) (\"bar\" ,acl)))\n")
 137   (with-test-package '((inputs `(("foo" ,gmp) ("bar" ,acl))))
 138     (list (package-direct-inputs (@ (my-packages) my-coreutils))
 139           (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
 140
 141 (test-equal "input labels, simple"
 142   (list `(("gmp" ,gmp) ("acl" ,acl))
 143         "      (inputs (list gmp acl))\n")
 144   (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
 145     (list (package-direct-inputs (@ (my-packages) my-coreutils))
 146           (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
 147
 148 (test-equal "input labels, long list with one item per line"
 149   (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
 150         "\
 151         (list gmp
 152               acl
 153               gmp
 154               acl
 155               gmp
 156               acl
 157               gmp
 158               acl))\n")
 159   (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
 160                                  ("gmp" ,gmp) ("acl" ,acl)
 161                                  ("gmp" ,gmp) ("acl" ,acl)
 162                                  ("gmp" ,gmp) ("acl" ,acl))))
 163     (list (package-direct-inputs (@ (my-packages) my-coreutils))
 164           (read-package-field (@ (my-packages) my-coreutils) 'inputs 8))))
 165
 166 (test-equal "input labels, sdl-union"
 167   "\
 168         (list gmp acl
 169               (sdl-union 1 2 3 4)))\n"
 170   (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
 171                                  ("sdl-union" ,(sdl-union 1 2 3 4)))))
 172     (read-package-field (@ (my-packages) my-coreutils) 'inputs 2)))
 173
 174 (test-equal "input labels, output"
 175   (list `(("gmp" ,gmp "debug") ("acl" ,acl))
 176         "      (inputs (list `(,gmp \"debug\") acl))\n")
 177   (with-test-package '((inputs `(("gmp" ,gmp "debug") ("acl" ,acl))))
 178     (list (package-direct-inputs (@ (my-packages) my-coreutils))
 179           (read-package-field (@ (my-packages) my-coreutils) 'inputs))))
 180
 181 (test-equal "input labels, prepend"
 182   (list `(("gmp" ,gmp) ("acl" ,acl))
 183         "\
 184         (modify-inputs (package-propagated-inputs coreutils)
 185           (prepend gmp acl)))\n")
 186   (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
 187                                  ,@(package-propagated-inputs coreutils))))
 188     (list (package-inputs (@ (my-packages) my-coreutils))
 189           (read-package-field (@ (my-packages) my-coreutils) 'inputs 2))))
 190
 191 (test-equal "input labels, prepend + delete"
 192   (list `(("gmp" ,gmp) ("acl" ,acl))
 193         "\
 194         (modify-inputs (package-propagated-inputs coreutils)
 195           (delete \"gmp\")
 196           (prepend gmp acl)))\n")
 197   (with-test-package '((inputs `(("gmp" ,gmp)
 198                                  ("acl" ,acl)
 199                                  ,@(alist-delete "gmp"
 200                                                  (package-propagated-inputs coreutils)))))
 201     (list (package-inputs (@ (my-packages) my-coreutils))
 202           (read-package-field (@ (my-packages) my-coreutils) 'inputs 3))))
 203
 204 (test-equal "input labels, prepend + delete multiple"
 205   (list `(("gmp" ,gmp) ("acl" ,acl))
 206         "\
 207         (modify-inputs (package-propagated-inputs coreutils)
 208           (delete \"foo\" \"bar\" \"baz\")
 209           (prepend gmp acl)))\n")
 210   (with-test-package '((inputs `(("gmp" ,gmp)
 211                                  ("acl" ,acl)
 212                                  ,@(fold alist-delete
 213                                          (package-propagated-inputs coreutils)
 214                                          '("foo" "bar" "baz")))))
 215     (list (package-inputs (@ (my-packages) my-coreutils))
 216           (read-package-field (@ (my-packages) my-coreutils) 'inputs 3))))
 217
 218 (test-equal "input labels, replace"
 219   (list '()                                 ;there's no "gmp" input to replace
 220         "\
 221         (modify-inputs (package-propagated-inputs coreutils)
 222           (replace \"gmp\" gmp)))\n")
 223   (with-test-package '((inputs `(("gmp" ,gmp)
 224                                  ,@(alist-delete "gmp"
 225                                                  (package-propagated-inputs coreutils)))))
 226     (list (package-inputs (@ (my-packages) my-coreutils))
 227           (read-package-field (@ (my-packages) my-coreutils) 'inputs 2))))
 228
 229 (test-equal "input labels, 'safe' policy"
 230   (list `(("gmp" ,gmp) ("acl" ,acl))
 231         "\
 232       (inputs (list gmp acl))\n")
 233   (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))
 234                             (arguments '()))      ;no build system arguments
 235     (lambda (directory)
 236       (define file
 237         (string-append directory "/my-packages.scm"))
 238
 239       (system* "guix" "style" "-L" directory "my-coreutils"
 240                "--input-simplification=safe")
 241
 242       (load file)
 243       (list (package-inputs (@ (my-packages) my-coreutils))
 244             (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
 245
 246 (test-equal "input labels, 'safe' policy, nothing changed"
 247   (list `(("GMP" ,gmp) ("ACL" ,acl))
 248         "\
 249       (inputs `((\"GMP\" ,gmp) (\"ACL\" ,acl)))\n")
 250   (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))
 251                             ;; Non-empty argument list, so potentially unsafe
 252                             ;; input simplification.
 253                             (arguments
 254                              '(#:configure-flags
 255                                (assoc-ref %build-inputs "GMP"))))
 256     (lambda (directory)
 257       (define file
 258         (string-append directory "/my-packages.scm"))
 259
 260       (system* "guix" "style" "-L" directory "my-coreutils"
 261                "--input-simplification=safe")
 262
 263       (load file)
 264       (list (package-inputs (@ (my-packages) my-coreutils))
 265             (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
 266
 267 (test-equal "input labels, margin comment"
 268   (list `(("gmp" ,gmp))
 269         `(("acl" ,acl))
 270         "      (inputs (list gmp)) ;margin comment\n"
 271         "      (native-inputs (list acl)) ;another one\n")
 272   (call-with-test-package '((inputs `(("gmp" ,gmp)))
 273                             (native-inputs `(("acl" ,acl))))
 274     (lambda (directory)
 275       (define file
 276         (string-append directory "/my-packages.scm"))
 277
 278       (substitute* file
 279         (("\"gmp\"(.*)$" _ rest)
 280          (string-append "\"gmp\"" (string-trim-right rest)
 281                         " ;margin comment\n"))
 282         (("\"acl\"(.*)$" _ rest)
 283          (string-append "\"acl\"" (string-trim-right rest)
 284                         " ;another one\n")))
 285       (system* "cat" file)
 286
 287       (system* "guix" "style" "-L" directory "my-coreutils")
 288
 289       (load file)
 290       (list (package-inputs (@ (my-packages) my-coreutils))
 291             (package-native-inputs (@ (my-packages) my-coreutils))
 292             (read-package-field (@ (my-packages) my-coreutils) 'inputs)
 293             (read-package-field (@ (my-packages) my-coreutils) 'native-inputs)))))
 294
 295 (test-equal "input labels, margin comment on long list"
 296   (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
 297         "\
 298         (list gmp ;margin comment
 299               acl
 300               gmp ;margin comment
 301               acl
 302               gmp ;margin comment
 303               acl
 304               gmp ;margin comment
 305               acl))\n")
 306   (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)
 307                                       ("gmp" ,gmp) ("acl" ,acl)
 308                                       ("gmp" ,gmp) ("acl" ,acl)
 309                                       ("gmp" ,gmp) ("acl" ,acl))))
 310     (lambda (directory)
 311       (define file
 312         (string-append directory "/my-packages.scm"))
 313
 314       (substitute* file
 315         (("\"gmp\"(.*)$" _ rest)
 316          (string-append "\"gmp\"" (string-trim-right rest)
 317                         " ;margin comment\n")))
 318       (system* "cat" file)
 319
 320       (system* "guix" "style" "-L" directory "my-coreutils")
 321
 322       (load file)
 323       (list (package-inputs (@ (my-packages) my-coreutils))
 324             (read-package-field (@ (my-packages) my-coreutils) 'inputs 8)))))
 325
 326 (test-equal "input labels, line comment"
 327   (list `(("gmp" ,gmp) ("acl" ,acl))
 328         "\
 329       (inputs (list gmp
 330                     ;; line comment!
 331                     acl))\n")
 332   (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
 333     (lambda (directory)
 334       (define file
 335         (string-append directory "/my-packages.scm"))
 336
 337       (substitute* file
 338         ((",gmp\\)(.*)$" _ rest)
 339          (string-append ",gmp)\n   ;; line comment!\n" rest)))
 340
 341       (system* "guix" "style" "-L" directory "my-coreutils")
 342
 343       (load file)
 344       (list (package-inputs (@ (my-packages) my-coreutils))
 345             (read-package-field (@ (my-packages) my-coreutils) 'inputs 3)))))
 346
 347 (test-equal "input labels, modify-inputs and margin comment"
 348   (list `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr))
 349         "\
 350         (modify-inputs (package-propagated-inputs coreutils)
 351           (prepend gmp ;margin comment
 352                    acl ;another one
 353                    mpfr)))\n")
 354   (call-with-test-package '((inputs
 355                              `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr)
 356                                ,@(package-propagated-inputs coreutils))))
 357     (lambda (directory)
 358       (define file
 359         (string-append directory "/my-packages.scm"))
 360
 361       (substitute* file
 362         ((",gmp\\)(.*)$" _ rest)
 363          (string-append ",gmp) ;margin comment\n" rest))
 364         ((",acl\\)(.*)$" _ rest)
 365          (string-append ",acl) ;another one\n" rest)))
 366
 367       (system* "guix" "style" "-L" directory "my-coreutils")
 368
 369       (load file)
 370       (list (package-inputs (@ (my-packages) my-coreutils))
 371             (read-package-field (@ (my-packages) my-coreutils) 'inputs 4)))))
 372
 373 (test-pretty-print "(list 1 2 3 4)")
 374 (test-pretty-print "(list 1
 375                           2
 376                           3
 377                           4)"
 378                    #:long-list 3
 379                    #:indent 20)
 380 (test-pretty-print "\
 381 (list abc
 382       def)"
 383                    #:max-width 11)
 384 (test-pretty-print "\
 385 (#:foo
 386  #:bar)"
 387                    #:max-width 10)
 388
 389 (test-pretty-print "\
 390 (#:first 1
 391  #:second 2
 392  #:third 3)")
 393
 394 (test-pretty-print "\
 395 ((x
 396   1)
 397  (y
 398   2)
 399  (z
 400   3))"
 401                    #:max-width 3)
 402
 403 (test-pretty-print "\
 404 (let ((x 1)
 405       (y 2)
 406       (z 3)
 407       (p 4))
 408   (+ x y))"
 409                    #:max-width 11)
 410
 411 (test-pretty-print "\
 412 (lambda (x y)
 413   ;; This is a procedure.
 414   (let ((z (+ x y)))
 415     (* z z)))")
 416
 417 (test-pretty-print "\
 418 #~(string-append #$coreutils \"/bin/uname\")")
 419
 420 (test-pretty-print "\
 421 (package
 422   (inherit coreutils)
 423   (version \"42\"))")
 424
 425 (test-pretty-print "\
 426 (modify-phases %standard-phases
 427   (add-after 'unpack 'post-unpack
 428     (lambda _
 429       #t))
 430   (add-before 'check 'pre-check
 431     (lambda* (#:key inputs #:allow-other-keys)
 432       do things ...)))")
 433
 434 (test-pretty-print "\
 435 (#:phases (modify-phases sdfsdf
 436             (add-before 'x 'y
 437               (lambda _
 438                 xyz))))")
 439
 440 (test-pretty-print "\
 441 (description \"abcdefghijkl
 442 mnopqrstuvwxyz.\")"
 443                    #:max-width 30)
 444
 445 (test-pretty-print "\
 446 (description
 447  \"abcdefghijkl
 448 mnopqrstuvwxyz.\")"
 449                    #:max-width 12)
 450
 451 (test-pretty-print "\
 452 (description
 453  \"abcdefghijklmnopqrstuvwxyz\")"
 454                    #:max-width 33)
 455
 456 (test-end)
 457
 458 ;; Local Variables:
 459 ;; eval: (put 'with-test-package 'scheme-indent-function 1)
 460 ;; eval: (put 'call-with-test-package 'scheme-indent-function 1)
 461 ;; End: