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 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))
  32
  33 (define (call-with-test-package inputs proc)
  34   (call-with-temporary-directory
  35    (lambda (directory)
  36      (call-with-output-file (string-append directory "/my-packages.scm")
  37        (lambda (port)
  38          (pretty-print
  39           `(begin
  40              (define-module (my-packages)
  41                #:use-module (guix)
  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))
  47
  48              (define base
  49                (package
  50                  (inherit coreutils)
  51                  (inputs '())
  52                  (native-inputs '())
  53                  (propagated-inputs '())))
  54
  55              (define (sdl-union . lst)
  56                (package
  57                  (inherit base)
  58                  (name "sdl-union")))
  59
  60              (define-public my-coreutils
  61                (package
  62                  (inherit base)
  63                  ,@inputs
  64                  (name "my-coreutils"))))
  65           port)))
  66
  67      (proc directory))))
  68
  69 (define test-directory
  70   ;; Directory where the package definition lives.
  71   (make-parameter #f))
  72
  73 (define-syntax-rule (with-test-package fields exp ...)
  74   (call-with-test-package fields
  75     (lambda (directory)
  76       (define file
  77         (string-append directory "/my-packages.scm"))
  78
  79       ;; Run as a separate process to make sure FILE is reloaded.
  80       (system* "guix" "style" "-L" directory "my-coreutils")
  81       (system* "cat" file)
  82
  83       (load file)
  84       (parameterize ((test-directory directory))
  85         exp ...))))
  86
  87 (define* (read-lines port line #:optional (count 1))
  88   "Read COUNT lines from PORT, starting from LINE."
  89   (let loop ((lines '())
  90              (count count))
  91     (cond ((< (port-line port) (- line 1))
  92            (read-char port)
  93            (loop lines count))
  94           ((zero? count)
  95            (string-concatenate-reverse lines))
  96           (else
  97            (match (read-line port 'concat)
  98              ((? eof-object?)
  99               (loop lines 0))
 100              (line
 101               (loop (cons line lines) (- count 1))))))))
 102
 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)
 108                               file
 109                               (string-append (test-directory) "/"
 110                                              file))
 111       (lambda (port)
 112         (read-lines port line count)))))
 113
 114 \f
 115 (test-begin "style")
 116
 117 (test-equal "nothing to rewrite"
 118   '()
 119   (with-test-package '()
 120     (package-direct-inputs (@ (my-packages) my-coreutils))))
 121
 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))))
 128
 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))))
 135
 136 (test-equal "input labels, long list with one item per line"
 137   (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
 138         "\
 139         (list gmp
 140               acl
 141               gmp
 142               acl
 143               gmp
 144               acl
 145               gmp
 146               acl))\n")
 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))))
 153
 154 (test-equal "input labels, sdl-union"
 155   "\
 156         (list gmp acl
 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)))
 161
 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))))
 168
 169 (test-equal "input labels, prepend"
 170   (list `(("gmp" ,gmp) ("acl" ,acl))
 171         "\
 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))))
 178
 179 (test-equal "input labels, prepend + delete"
 180   (list `(("gmp" ,gmp) ("acl" ,acl))
 181         "\
 182         (modify-inputs (package-propagated-inputs coreutils)
 183           (delete \"gmp\")
 184           (prepend gmp acl)))\n")
 185   (with-test-package '((inputs `(("gmp" ,gmp)
 186                                  ("acl" ,acl)
 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))))
 191
 192 (test-equal "input labels, prepend + delete multiple"
 193   (list `(("gmp" ,gmp) ("acl" ,acl))
 194         "\
 195         (modify-inputs (package-propagated-inputs coreutils)
 196           (delete \"foo\" \"bar\" \"baz\")
 197           (prepend gmp acl)))\n")
 198   (with-test-package '((inputs `(("gmp" ,gmp)
 199                                  ("acl" ,acl)
 200                                  ,@(fold alist-delete
 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))))
 205
 206 (test-equal "input labels, replace"
 207   (list '()                                 ;there's no "gmp" input to replace
 208         "\
 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))))
 216
 217 (test-equal "input labels, 'safe' policy"
 218   (list `(("gmp" ,gmp) ("acl" ,acl))
 219         "\
 220       (inputs (list gmp acl))\n")
 221   (call-with-test-package '((inputs `(("GMP" ,gmp) ("ACL" ,acl)))
 222                             (arguments '()))      ;no build system arguments
 223     (lambda (directory)
 224       (define file
 225         (string-append directory "/my-packages.scm"))
 226
 227       (system* "guix" "style" "-L" directory "my-coreutils"
 228                "--input-simplification=safe")
 229
 230       (load file)
 231       (list (package-inputs (@ (my-packages) my-coreutils))
 232             (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
 233
 234 (test-equal "input labels, 'safe' policy, nothing changed"
 235   (list `(("GMP" ,gmp) ("ACL" ,acl))
 236         "\
 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.
 241                             (arguments
 242                              '(#:configure-flags
 243                                (assoc-ref %build-inputs "GMP"))))
 244     (lambda (directory)
 245       (define file
 246         (string-append directory "/my-packages.scm"))
 247
 248       (system* "guix" "style" "-L" directory "my-coreutils"
 249                "--input-simplification=safe")
 250
 251       (load file)
 252       (list (package-inputs (@ (my-packages) my-coreutils))
 253             (read-package-field (@ (my-packages) my-coreutils) 'inputs)))))
 254
 255 (test-equal "input labels, margin comment"
 256   (list `(("gmp" ,gmp))
 257         `(("acl" ,acl))
 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))))
 262     (lambda (directory)
 263       (define file
 264         (string-append directory "/my-packages.scm"))
 265
 266       (substitute* file
 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)
 272                         " ;another one\n")))
 273       (system* "cat" file)
 274
 275       (system* "guix" "style" "-L" directory "my-coreutils")
 276
 277       (load file)
 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)))))
 282
 283 (test-equal "input labels, margin comment on long list"
 284   (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl))))
 285         "\
 286         (list gmp ;margin comment
 287               acl
 288               gmp ;margin comment
 289               acl
 290               gmp ;margin comment
 291               acl
 292               gmp ;margin comment
 293               acl))\n")
 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))))
 298     (lambda (directory)
 299       (define file
 300         (string-append directory "/my-packages.scm"))
 301
 302       (substitute* file
 303         (("\"gmp\"(.*)$" _ rest)
 304          (string-append "\"gmp\"" (string-trim-right rest)
 305                         " ;margin comment\n")))
 306       (system* "cat" file)
 307
 308       (system* "guix" "style" "-L" directory "my-coreutils")
 309
 310       (load file)
 311       (list (package-inputs (@ (my-packages) my-coreutils))
 312             (read-package-field (@ (my-packages) my-coreutils) 'inputs 8)))))
 313
 314 (test-equal "input labels, line comment"
 315   (list `(("gmp" ,gmp) ("acl" ,acl))
 316         "\
 317       (inputs (list gmp
 318                     ;; line comment!
 319                     acl))\n")
 320   (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl))))
 321     (lambda (directory)
 322       (define file
 323         (string-append directory "/my-packages.scm"))
 324
 325       (substitute* file
 326         ((",gmp\\)(.*)$" _ rest)
 327          (string-append ",gmp)\n   ;; line comment!\n" rest)))
 328
 329       (system* "guix" "style" "-L" directory "my-coreutils")
 330
 331       (load file)
 332       (list (package-inputs (@ (my-packages) my-coreutils))
 333             (read-package-field (@ (my-packages) my-coreutils) 'inputs 3)))))
 334
 335 (test-equal "input labels, modify-inputs and margin comment"
 336   (list `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr))
 337         "\
 338         (modify-inputs (package-propagated-inputs coreutils)
 339           (prepend gmp ;margin comment
 340                    acl ;another one
 341                    mpfr)))\n")
 342   (call-with-test-package '((inputs
 343                              `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr)
 344                                ,@(package-propagated-inputs coreutils))))
 345     (lambda (directory)
 346       (define file
 347         (string-append directory "/my-packages.scm"))
 348
 349       (substitute* file
 350         ((",gmp\\)(.*)$" _ rest)
 351          (string-append ",gmp) ;margin comment\n" rest))
 352         ((",acl\\)(.*)$" _ rest)
 353          (string-append ",acl) ;another one\n" rest)))
 354
 355       (system* "guix" "style" "-L" directory "my-coreutils")
 356
 357       (load file)
 358       (list (package-inputs (@ (my-packages) my-coreutils))
 359             (read-package-field (@ (my-packages) my-coreutils) 'inputs 4)))))
 360
 361 (test-end)
 362
 363 ;; Local Variables:
 364 ;; eval: (put 'with-test-package 'scheme-indent-function 1)
 365 ;; eval: (put 'call-with-test-package 'scheme-indent-function 1)
 366 ;; End: