diff options
author | Marius Bakke <marius@gnu.org> | 2022-08-11 22:15:22 +0200 |
---|---|---|
committer | Marius Bakke <marius@gnu.org> | 2022-08-11 22:15:22 +0200 |
commit | b50eaa67642ebc25e9c896f2e700c08610e0a5da (patch) | |
tree | e3358208e17a836c2e3cdb3125f815a2ab35c2b8 /guix | |
parent | 7b69cd07408bf64fff026e4597920a90259e3205 (diff) | |
parent | 99b73f60415b282f2be39134f385cbda4840c336 (diff) |
Merge branch 'master' into staging
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build-system/asdf.scm | 18 | ||||
-rw-r--r-- | guix/build-system/channel.scm | 78 | ||||
-rw-r--r-- | guix/build-system/perl.scm | 122 | ||||
-rw-r--r-- | guix/build-system/qt.scm | 14 | ||||
-rw-r--r-- | guix/build/asdf-build-system.scm | 33 | ||||
-rw-r--r-- | guix/build/download.scm | 103 | ||||
-rw-r--r-- | guix/build/lisp-utils.scm | 46 | ||||
-rw-r--r-- | guix/build/qt-utils.scm | 48 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 3 | ||||
-rw-r--r-- | guix/channels.scm | 27 | ||||
-rw-r--r-- | guix/lint.scm | 4 | ||||
-rw-r--r-- | guix/read-print.scm | 696 | ||||
-rw-r--r-- | guix/scripts/build.scm | 29 | ||||
-rw-r--r-- | guix/scripts/describe.scm | 40 | ||||
-rw-r--r-- | guix/scripts/environment.scm | 27 | ||||
-rw-r--r-- | guix/scripts/gc.scm | 6 | ||||
-rw-r--r-- | guix/scripts/import.scm | 4 | ||||
-rw-r--r-- | guix/scripts/lint.scm | 22 | ||||
-rw-r--r-- | guix/scripts/style.scm | 527 | ||||
-rw-r--r-- | guix/scripts/system.scm | 5 | ||||
-rw-r--r-- | guix/self.scm | 1 | ||||
-rw-r--r-- | guix/ssh.scm | 4 | ||||
-rw-r--r-- | guix/tests/git.scm | 1 | ||||
-rw-r--r-- | guix/utils.scm | 12 |
24 files changed, 1195 insertions, 675 deletions
diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index a0f4634db0..74a3e47da1 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -1,7 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> -;;; Copyright © 2019, 2020, 2021 Guillaume Le Vaillant <glv@posteo.net> +;;; Copyright © 2019, 2020, 2021, 2022 Guillaume Le Vaillant <glv@posteo.net> ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022 Pierre Neidhardt <mail@ambrevar.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -202,7 +203,7 @@ set up using CL source package conventions." (define base-arguments (if target-is-source? (strip-keyword-arguments - '(#:tests? #:asd-files #:lisp #:asd-systems #:test-asd-file) + '(#:tests? #:lisp #:asd-systems #:asd-test-systems #:asd-operation) (package-arguments pkg)) (package-arguments pkg))) @@ -270,9 +271,9 @@ set up using CL source package conventions." (lambda* (name inputs #:key source outputs (tests? #t) - (asd-files ''()) (asd-systems ''()) - (test-asd-file #f) + (asd-test-systems ''()) + (asd-operation "load-system") (phases '%standard-phases) (search-paths '()) (system (%current-system)) @@ -292,6 +293,11 @@ set up using CL source package conventions." `(quote ,(list package-name))) asd-systems)) + (define test-systems + (if (null? (cadr asd-test-systems)) + systems + asd-test-systems)) + (define builder (with-imported-modules imported-modules #~(begin @@ -302,9 +308,9 @@ set up using CL source package conventions." (%lisp-type #$lisp-type)) (asdf-build #:name #$name #:source #+source - #:asd-files #$asd-files #:asd-systems #$systems - #:test-asd-file #$test-asd-file + #:asd-test-systems #$test-systems + #:asd-operation #$asd-operation #:system #$system #:tests? #$tests? #:phases #$phases diff --git a/guix/build-system/channel.scm b/guix/build-system/channel.scm new file mode 100644 index 0000000000..6ad377f930 --- /dev/null +++ b/guix/build-system/channel.scm @@ -0,0 +1,78 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019-2022 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build-system channel) + #:use-module ((guix store) #:select (%store-monad store-lift)) + #:use-module ((guix gexp) #:select (lower-object)) + #:use-module (guix monads) + #:use-module (guix channels) + #:use-module (guix build-system) + #:export (channel-build-system)) + +;;; Commentary: +;;; +;;; The "channel" build system lets you build Guix instances from channel +;;; specifications, similar to how 'guix time-machine' would do it, as regular +;;; packages. +;;; +;;; Code: + +(define latest-channel-instances* + (store-lift latest-channel-instances)) + +(define* (build-channels name inputs + #:key source system commit + (authenticate? #t) + #:allow-other-keys) + (mlet* %store-monad ((instances + (cond ((channel-instance? source) + (return (list source))) + ((channel? source) + (latest-channel-instances* + (list source) + #:authenticate? authenticate?)) + ((string? source) + ;; If SOURCE is a store file name, as is the + ;; case when called from (gnu ci), return it as + ;; is. + (return + (list (checkout->channel-instance + source #:commit commit)))) + (else + (mlet %store-monad ((source + (lower-object source))) + (return + (list (checkout->channel-instance + source #:commit commit)))))))) + (channel-instances->derivation instances))) + +(define channel-build-system + ;; Build system used to "convert" a channel instance to a package. + (let ((lower (lambda* (name #:key system source commit (authenticate? #t) + #:allow-other-keys) + (bag + (name name) + (system system) + (build build-channels) + (arguments `(#:source ,source + #:authenticate? ,authenticate? + #:commit ,commit)))))) + (build-system (name 'channel) + (description "Turn a channel instance into a package.") + (lower lower)))) + diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index db0a916fb2..43ec2fdcb6 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,13 +30,17 @@ #:use-module (ice-9 match) #:export (%perl-build-system-modules perl-build + perl-cross-build perl-build-system)) ;; Commentary: ;; ;; Standard build procedure for Perl packages using the "makefile ;; maker"---i.e., "perl Makefile.PL". This is implemented as an extension of -;; `gnu-build-system'. +;; `gnu-build-system'. Cross-compilation is supported for some simple Perl +;; packages, but not for any Perl packages that do things like XS (Perl's FFI), +;; which makes C-style shared libraries, as it is currently not known how to +;; tell Perl to properly cross-compile. ;; ;; Code: @@ -59,24 +64,44 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:target #:perl #:inputs #:native-inputs)) + `(#:perl #:inputs #:native-inputs + ,@(if target '() '(#:target)))) - (and (not target) ;XXX: no cross-compilation - (bag - (name name) - (system system) - (host-inputs `(,@(if source - `(("source" ,source)) - '()) - ,@inputs + (bag + (name name) + (system system) (target target) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + ;; For interpreters in #! (shebang) + ,@(if target + `(("perl" ,perl)) + '()) - ;; Keep the standard inputs of 'gnu-build-system'. - ,@(standard-packages))) - (build-inputs `(("perl" ,perl) - ,@native-inputs)) - (outputs outputs) - (build perl-build) - (arguments (strip-keyword-arguments private-keywords arguments))))) + ;; Keep the standard inputs of 'gnu-build-system'. + ;; TODO: make this unconditional, putting this into + ;; 'build-inputs'. + ,@(if target + '() + (standard-packages)))) + (build-inputs `(("perl" ,perl) + ,@native-inputs + ,@(if target + (standard-cross-packages target 'host) + '()) + ,@(if target + (standard-packages) + '()))) + ;; Keep the standard inputs of 'gnu-build-system'. + (target-inputs (if target + (standard-cross-packages target 'target) + '())) + (outputs outputs) + (build (if target + perl-cross-build + perl-build)) + (arguments (strip-keyword-arguments private-keywords arguments)))) (define* (perl-build name inputs #:key source @@ -127,6 +152,69 @@ provides a `Makefile.PL' file as its build system." (gexp->derivation name build #:system system #:target #f + #:graft? #f + #:guile-for-build guile))) + +(define* (perl-cross-build name #:key + source + target + build-inputs host-inputs target-inputs + (search-paths '()) + (native-search-paths '()) + (tests? #f) ; usually not possible when cross-compiling + (parallel-build? #t) + (parallel-tests? #t) + (make-maker? #f) + (make-maker-flags ''()) + (module-build-flags ''()) + (phases '(@ (guix build perl-build-system) + %standard-phases)) + (outputs '("out")) + (system (%current-system)) + (build (nix-system->gnu-triplet system)) + (guile #f) + (imported-modules %perl-build-system-modules) + (modules '((guix build perl-build-system) + (guix build utils)))) + "Cross-build SOURCE to TARGET using PERL, and with INPUTS. This assumes +that SOURCE provides a `Makefile.PL' file as its build system and does not use +XS or similar." + (define inputs + #~(append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) + (define builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (perl-build #:name #$name + #:source #+source + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:native-search-paths + '#$(sexp->gexp + (map search-path-specification->sexp + native-search-paths)) + #:make-maker? #$make-maker? + #:make-maker-flags #$make-maker-flags + #:module-build-flags #$(sexp->gexp module-build-flags) + #:phases #$phases + #:build #$build + #:system #$system + #:target #$target + #:test-target "test" + #:tests? #$tests? + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:outputs #$(outputs->gexp outputs) + #:inputs #$inputs + #:native-inputs #+(input-tuples->gexp build-inputs))))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target target + #:graft? #false #:guile-for-build guile))) (define perl-build-system diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm index a0b968cef3..a9bf728f25 100644 --- a/guix/build-system/qt.scm +++ b/guix/build-system/qt.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> +;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -67,11 +68,19 @@ (let ((module (resolve-interface '(gnu packages cmake)))) (module-ref module 'cmake-minimal))) +(define (default-qtbase) + "Return the default qtbase package." + + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages qt)))) + (module-ref module 'qtbase-5))) + ;; This barely is a copy from (guix build-system cmake), only adjusted to use ;; the variables defined here. (define* (lower name #:key source inputs native-inputs outputs system target (cmake (default-cmake)) + (qtbase (default-qtbase)) #:allow-other-keys #:rest arguments) "Return a bag for NAME." @@ -87,6 +96,7 @@ `(("source" ,source)) '()) ,@`(("cmake" ,cmake)) + ,@`(("qtbase" ,qtbase)) ,@native-inputs ,@(if target ;; Use the standard cross inputs of @@ -112,6 +122,7 @@ (define* (qt-build name inputs #:key + (qtbase (default-qtbase)) source (guile #f) (outputs '("out")) (configure-flags ''()) (search-paths '()) @@ -150,6 +161,7 @@ provides a 'CMakeLists.txt' file as its build system." #:phases #$(if (pair? phases) (sexp->gexp phases) phases) + #:qtbase #+qtbase #:qt-wrap-excluded-outputs #$qt-wrap-excluded-outputs #:qt-wrap-excluded-inputs #$qt-wrap-excluded-inputs #:configure-flags #$configure-flags @@ -181,6 +193,7 @@ provides a 'CMakeLists.txt' file as its build system." #:key source target build-inputs target-inputs host-inputs + (qtbase (default-qtbase)) (guile #f) (outputs '("out")) (configure-flags ''()) @@ -237,6 +250,7 @@ build system." search-path-specification->sexp native-search-paths) #:phases #$phases + #:qtbase #+qtbase #:configure-flags #$configure-flags #:make-flags #$make-flags #:out-of-source? #$out-of-source? diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index 6186613e52..92154e7d34 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> -;;; Copyright © 2020, 2021 Guillaume Le Vaillant <glv@posteo.net> +;;; Copyright © 2020, 2021, 2022 Guillaume Le Vaillant <glv@posteo.net> +;;; Copyright © 2022 Pierre Neidhardt <mail@ambrevar.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -78,16 +79,6 @@ (,(library-directory object-output) :**/ :*.*.*))) -(define (source-asd-file output name asd-file) - (string-append (lisp-source-directory output name) "/" asd-file)) - -(define (find-asd-files output name asd-files) - (if (null? asd-files) - (find-files (lisp-source-directory output name) "\\.asd$") - (map (lambda (asd-file) - (source-asd-file output name asd-file)) - asd-files))) - (define (copy-files-to-output out name) "Copy all files from the current directory to OUT. Create an extra link to any system-defining files in the source to a convenient location. This is @@ -190,7 +181,7 @@ if it's present in the native-inputs." (setenv "XDG_CONFIG_DIRS" (string-append out "/etc"))) #t) -(define* (build #:key outputs inputs asd-files asd-systems +(define* (build #:key outputs inputs asd-systems asd-operation #:allow-other-keys) "Compile the system." (let* ((out (library-output outputs)) @@ -198,26 +189,22 @@ if it's present in the native-inputs." (source-path (string-append out (%lisp-source-install-prefix))) (translations (wrap-output-translations `(,(output-translation source-path - out)))) - (asd-files (find-asd-files out system-name asd-files))) + out))))) (setenv "ASDF_OUTPUT_TRANSLATIONS" (replace-escaped-macros (format #f "~S" translations))) (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache - (compile-systems asd-systems asd-files)) + (compile-systems asd-systems + (lisp-source-directory out system-name) + asd-operation)) #t) -(define* (check #:key tests? outputs inputs asd-files asd-systems - test-asd-file +(define* (check #:key tests? outputs inputs asd-test-systems #:allow-other-keys) "Test the system." (let* ((out (library-output outputs)) - (system-name (main-system-name out)) - (asd-files (find-asd-files out system-name asd-files)) - (test-asd-file - (and=> test-asd-file - (cut source-asd-file out system-name <>)))) + (system-name (main-system-name out))) (if tests? - (test-system (first asd-systems) asd-files test-asd-file) + (test-system asd-test-systems (lisp-source-directory out system-name)) (format #t "test suite not run~%"))) #t) diff --git a/guix/build/download.scm b/guix/build/download.scm index 41583e8143..db0a39084b 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -245,6 +245,54 @@ way." (set-exception-printer! 'tls-certificate-error print-tls-certificate-error) +(define (wrap-record-port-for-gnutls<3.7.7 record port) + "Return a port that wraps RECORD to ensure that closing it also closes PORT, +the actual socket port, and its file descriptor. Make sure it does not +introduce extra buffering (custom ports are buffered by default as of Guile +3.0.5). + +This wrapper is unnecessary with GnuTLS >= 3.7.7, which can automatically +close SESSION's file descriptor when RECORD is closed." + (define (read! bv start count) + (define read + (catch 'gnutls-error + (lambda () + (get-bytevector-n! record bv start count)) + (lambda (key err proc . rest) + ;; When responding to "Connection: close" requests, some servers + ;; close the connection abruptly after sending the response body, + ;; without doing a proper TLS connection termination. Treat it as + ;; EOF. This is fixed in GnuTLS 3.7.7. + (if (eq? err error/premature-termination) + the-eof-object + (apply throw key err proc rest))))) + + (if (eof-object? read) + 0 + read)) + (define (write! bv start count) + (put-bytevector record bv start count) + (force-output record) + count) + (define (get-position) + (port-position record)) + (define (set-position! new-position) + (set-port-position! record new-position)) + (define (close) + (unless (port-closed? port) + (close-port port)) + (unless (port-closed? record) + (close-port record))) + + (define (unbuffered port) + (setvbuf port 'none) + port) + + (unbuffered + (make-custom-binary-input/output-port "gnutls wrapped port" read! write! + get-position set-position! + close))) + (define* (tls-wrap port server #:key (verify-certificate? #t)) "Return PORT wrapped in a TLS connection to SERVER. SERVER must be a DNS host name without trailing dot." @@ -317,55 +365,13 @@ host name without trailing dot." (apply throw args)))) (let ((record (session-record-port session))) - (define (read! bv start count) - (define read - (catch 'gnutls-error - (lambda () - (get-bytevector-n! record bv start count)) - (lambda (key err proc . rest) - ;; When responding to "Connection: close" requests, some - ;; servers close the connection abruptly after sending the - ;; response body, without doing a proper TLS connection - ;; termination. Treat it as EOF. - (if (eq? err error/premature-termination) - the-eof-object - (apply throw key err proc rest))))) - - (if (eof-object? read) - 0 - read)) - (define (write! bv start count) - (put-bytevector record bv start count) - (force-output record) - count) - (define (get-position) - (port-position record)) - (define (set-position! new-position) - (set-port-position! record new-position)) - (define (close) - (unless (port-closed? port) - (close-port port)) - (unless (port-closed? record) - (close-port record))) - - (define (unbuffered port) - (setvbuf port 'none) - port) - (setvbuf record 'block) - - ;; Return a port that wraps RECORD to ensure that closing it also - ;; closes PORT, the actual socket port, and its file descriptor. - ;; Make sure it does not introduce extra buffering (custom ports - ;; are buffered by default as of Guile 3.0.5). - ;; XXX: This wrapper would be unnecessary if GnuTLS could - ;; automatically close SESSION's file descriptor when RECORD is - ;; closed, but that doesn't seem to be possible currently (as of - ;; 3.6.9). - (unbuffered - (make-custom-binary-input/output-port "gnutls wrapped port" read! write! - get-position set-position! - close))))) + (if (module-defined? (resolve-interface '(gnutls)) + 'set-session-record-port-close!) ;GnuTLS >= 3.7.7 + (let ((close-wrapped-port (lambda (_) (close-port port)))) + (set-session-record-port-close! record close-wrapped-port) + record) + (wrap-record-port-for-gnutls<3.7.7 record port))))) (define (ensure-uri uri-or-string) ;XXX: copied from (web http) (cond @@ -744,6 +750,7 @@ otherwise simply ignore them." (progress-reporter/file (uri-abbreviation uri) size))) (newline))) + (close-port port) file))) ((ftp) (false-if-exception* (ftp-fetch uri file diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 17d2637f87..646d4a3365 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> -;;; Copyright © 2020 Guillaume Le Vaillant <glv@posteo.net> +;;; Copyright © 2020, 2022 Guillaume Le Vaillant <glv@posteo.net> +;;; Copyright © 2022 Pierre Neidhardt <mail@ambrevar.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -107,38 +108,31 @@ with PROGRAM." "--eval" "(quit)")) (_ (error "The LISP provided is not supported at this time.")))) -(define (compile-systems systems asd-files) - "Use a lisp implementation to compile the SYSTEMS using asdf. -Load ASD-FILES first." +(define (compile-systems systems directory operation) + "Use a lisp implementation to compile the SYSTEMS using asdf." (lisp-eval-program `((require :asdf) - ,@(map (lambda (asd-file) - `(asdf:load-asd (truename ,asd-file))) - asd-files) + (asdf:initialize-source-registry + (list :source-registry (list :tree (uiop:ensure-pathname ,directory + :truenamize t + :ensure-directory t)) + :inherit-configuration)) ,@(map (lambda (system) - `(asdf:compile-system ,system)) + (list (string->symbol (string-append "asdf:" operation)) system)) systems)))) -(define (test-system system asd-files test-asd-file) - "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILES first. -Also load TEST-ASD-FILE if necessary." +(define (test-system test-systems directory) + "Use a lisp implementation to test the TEST-SYSTEMS using asdf." (lisp-eval-program `((require :asdf) - ,@(map (lambda (asd-file) - `(asdf:load-asd (truename ,asd-file))) - asd-files) - ,@(if test-asd-file - `((asdf:load-asd (truename ,test-asd-file))) - ;; Try some likely files. - (map (lambda (file) - `(when (uiop:file-exists-p ,file) - (asdf:load-asd (truename ,file)))) - (list - (string-append system "-tests.asd") - (string-append system "-test.asd") - "tests.asd" - "test.asd"))) - (asdf:test-system ,system)))) + (asdf:initialize-source-registry + (list :source-registry (list :tree (uiop:ensure-pathname ,directory + :truenamize t + :ensure-directory t)) + :inherit-configuration)) + ,@(map (lambda (system) + `(asdf:test-system ,system)) + test-systems)))) (define (string->lisp-keyword . strings) "Return a lisp keyword for the concatenation of STRINGS." diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm index fa018a93ac..2e47f1bc02 100644 --- a/guix/build/qt-utils.scm +++ b/guix/build/qt-utils.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2019, 2020, 2021 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot> ;;; ;;; This file is part of GNU Guix. @@ -26,10 +26,13 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) #:export (wrap-qt-program wrap-all-qt-programs %qt-wrap-excluded-inputs)) +(define %default-qt-major-version "5") + (define %qt-wrap-excluded-inputs '(list "cmake" "extra-cmake-modules" "qttools")) @@ -37,7 +40,9 @@ ;; facilities for per-application data directories, such as ;; /share/quassel. Thus, we include the output directory even if it doesn't ;; contain any of the standard subdirectories. -(define (variables-for-wrapping base-directories output-directory) +(define* (variables-for-wrapping base-directories output-directory + #:key + (qt-major-version %default-qt-major-version)) (define (collect-sub-dirs base-directories file-type subdirectory selectors) ;; Append SUBDIRECTORY and each of BASE-DIRECTORIES, and return the subset @@ -82,17 +87,20 @@ "/applications" "/cursors" "/fonts" "/icons" "/glib-2.0/schemas" "/mime" "/sounds" "/themes" "/wallpapers") '("XDG_CONFIG_DIRS" suffix directory "/etc/xdg") - ;; The following variables can be extended by the user, but not - ;; overridden, to ensure proper operation. - '("QT_PLUGIN_PATH" prefix directory "/lib/qt5/plugins") - '("QML2_IMPORT_PATH" prefix directory "/lib/qt5/qml") + ;; We wrap exactly to avoid potentially mixing Qt5/Qt6 components, which + ;; would cause warnings, perhaps problems. + `("QT_PLUGIN_PATH" = directory + ,(format #f "/lib/qt~a/plugins" qt-major-version)) + `("QML2_IMPORT_PATH" = directory + ,(format #f "/lib/qt~a/qml" qt-major-version)) ;; QTWEBENGINEPROCESS_PATH accepts a single value, which makes 'exact the ;; most suitable environment variable type for it. - '("QTWEBENGINEPROCESS_PATH" = regular - "/lib/qt5/libexec/QtWebEngineProcess")))) + `("QTWEBENGINEPROCESS_PATH" = regular + ,(format #f "/lib/qt~a/libexec/QtWebEngineProcess" qt-major-version))))) (define* (wrap-qt-program* program #:key inputs output-dir - qt-wrap-excluded-inputs) + qt-wrap-excluded-inputs + (qt-major-version %default-qt-major-version)) (define input-directories (filter-map @@ -104,12 +112,14 @@ (let ((vars-to-wrap (variables-for-wrapping (cons output-dir input-directories) - output-dir))) + output-dir + #:qt-major-version qt-major-version))) (when (not (null? vars-to-wrap)) (apply wrap-program program vars-to-wrap)))) (define* (wrap-qt-program program-name #:key inputs output - (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs)) + (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs) + (qt-major-version %default-qt-major-version)) "Wrap the specified program (which must reside in the OUTPUT's \"/bin\" directory) with suitably set environment variables. @@ -117,9 +127,11 @@ This is like qt-build-systems's phase \"qt-wrap\", but only the named program is wrapped." (wrap-qt-program* (string-append output "/bin/" program-name) #:output-dir output #:inputs inputs - #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs)) + #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs + #:qt-major-version qt-major-version)) (define* (wrap-all-qt-programs #:key inputs outputs + qtbase (qt-wrap-excluded-outputs '()) (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs) #:allow-other-keys) @@ -131,6 +143,15 @@ Wrapping is not applied to outputs whose name is listed in QT-WRAP-EXCLUDED-OUTPUTS. This is useful when an output is known not to contain any Qt binaries, and where wrapping would gratuitously add a dependency of that output on Qt." + (define qt-major-version + (if qtbase + (let ((_ version (package-name->name+version + (strip-store-file-name qtbase)))) + (first (string-split version #\.))) + ;; Provide a fall-back for build systems not having a #:qtbase + ;; argument. + %default-qt-major-version)) + (define (find-files-to-wrap output-dir) (append-map (lambda (dir) @@ -149,7 +170,8 @@ add a dependency of that output on Qt." (unless (member output qt-wrap-excluded-outputs) (for-each (cut wrap-qt-program* <> #:output-dir output-dir #:inputs inputs - #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs) + #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs + #:qt-major-version qt-major-version) (find-files-to-wrap output-dir)))))) (for-each handle-output outputs)) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index a7401fd73f..eda487f52e 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2022 Oleg Pykhalov <go.wigust@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -49,6 +50,7 @@ MS_RELATIME MS_BIND MS_MOVE + MS_SHARED MS_LAZYTIME MNT_FORCE MNT_DETACH @@ -537,6 +539,7 @@ the last argument of `mknod'." (define MS_NOATIME 1024) (define MS_BIND 4096) (define MS_MOVE 8192) +(define MS_SHARED 1048576) (define MS_RELATIME 2097152) (define MS_STRICTATIME 16777216) (define MS_LAZYTIME 33554432) diff --git a/guix/channels.scm b/guix/channels.scm index 689b30e0eb..ad6d3fb8ac 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -77,6 +77,7 @@ %default-guix-channel %default-channels guix-channel? + repository->guix-channel channel-instance? channel-instance-channel @@ -202,6 +203,26 @@ introduction, add it." (introduction %guix-channel-introduction)) chan)) +(define* (repository->guix-channel directory + #:key + (introduction %guix-channel-introduction)) + "Look for a Git repository in DIRECTORY or its ancestors and return a +channel that uses that repository and the commit HEAD currently points to; use +INTRODUCTION as the channel's introduction. Return #f if no Git repository +could be found at DIRECTORY or one of its ancestors." + (catch 'git-error + (lambda () + (with-repository (repository-discover directory) repository + (let* ((head (repository-head repository)) + (commit (oid->string (reference-target head)))) + (channel + (inherit %default-guix-channel) + (url (repository-working-directory repository)) + (commit commit) + (branch (reference-shorthand head)) + (introduction introduction))))) + (const #f))) + (define-record-type <channel-instance> (channel-instance channel commit checkout) channel-instance? @@ -1132,7 +1153,11 @@ NEW. When OLD is omitted or is #f, return all the news entries of CHANNEL." (if (and news-file (file-exists? news-file)) (with-repository checkout repository (let* ((news (call-with-input-file news-file - read-channel-news)) + (lambda (port) + (set-port-encoding! port + (or (file-encoding port) + "UTF-8")) + (read-channel-news port)))) (entries (map (lambda (entry) (resolve-channel-news-entry-tag repository entry)) diff --git a/guix/lint.scm b/guix/lint.scm index 73581b518f..edba1c2663 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -492,7 +492,7 @@ of a package, and INPUT-NAMES, a list of package specifications such as "kdoctools" "libtool" "m4" - "qttools" + "qttools-5" "yasm" "nasm" "fasm" "python-coverage" "python-cython" @@ -507,7 +507,7 @@ of a package, and INPUT-NAMES, a list of package specifications such as "scdoc" "swig" "qmake" - "qttools" + "qttools-5" "texinfo" "xorg-server-for-tests" "yelp-tools"))) diff --git a/guix/read-print.scm b/guix/read-print.scm new file mode 100644 index 0000000000..63ff9ca5bd --- /dev/null +++ b/guix/read-print.scm @@ -0,0 +1,696 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix read-print) + #:use-module (ice-9 control) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (guix i18n) + #:use-module ((guix diagnostics) + #:select (formatted-message + &fix-hint &error-location + location)) + #:export (pretty-print-with-comments + pretty-print-with-comments/splice + read-with-comments + read-with-comments/sequence + object->string* + + blank? + + vertical-space + vertical-space? + vertical-space-height + canonicalize-vertical-space + + page-break + page-break? + + comment + comment? + comment->string + comment-margin? + canonicalize-comment)) + +;;; Commentary: +;;; +;;; This module provides a comment-preserving reader and a comment-preserving +;;; pretty-printer smarter than (ice-9 pretty-print). +;;; +;;; Code: + + +;;; +;;; Comment-preserving reader. +;;; + +(define <blank> + ;; The parent class for "blanks". + (make-record-type '<blank> '() + (lambda (obj port) + (format port "#<blank ~a>" + (number->string (object-address obj) 16))) + #:extensible? #t)) + +(define blank? (record-predicate <blank>)) + +(define <vertical-space> + (make-record-type '<vertical-space> '(height) + #:parent <blank> + #:extensible? #f)) + +(define vertical-space? (record-predicate <vertical-space>)) +(define vertical-space (record-type-constructor <vertical-space>)) +(define vertical-space-height (record-accessor <vertical-space> 'height)) + +(define canonicalize-vertical-space + (let ((unit (vertical-space 1))) + (lambda (space) + "Return a vertical space corresponding to a single blank line." + unit))) + +(define <page-break> + (make-record-type '<page-break> '() + #:parent <blank> + #:extensible? #f)) + +(define page-break? (record-predicate <page-break>)) +(define page-break + (let ((break ((record-type-constructor <page-break>)))) + (lambda () + break))) + + +(define <comment> + ;; Comments. + (make-record-type '<comment> '(str margin?) + #:parent <blank> + #:extensible? #f)) + +(define comment? (record-predicate <comment>)) +(define string->comment (record-type-constructor <comment>)) +(define comment->string (record-accessor <comment> 'str)) +(define comment-margin? (record-accessor <comment> 'margin?)) + +(define* (comment str #:optional margin?) + "Return a new comment made from STR. When MARGIN? is true, return a margin +comment; otherwise return a line comment. STR must start with a semicolon and +end with newline, otherwise an error is raised." + (when (or (string-null? str) + (not (eqv? #\; (string-ref str 0))) + (not (string-suffix? "\n" str))) + (raise (condition + (&message (message "invalid comment string"))))) + (string->comment str margin?)) + +(define char-set:whitespace-sans-page-break + ;; White space, excluding #\page. + (char-set-difference char-set:whitespace (char-set #\page))) + +(define (space? chr) + "Return true if CHR is white space, except for page breaks." + (char-set-contains? char-set:whitespace-sans-page-break chr)) + +(define (read-vertical-space port) + "Read from PORT until a non-vertical-space character is met, and return a +single <vertical-space> record." + (let loop ((height 1)) + (match (read-char port) + (#\newline (loop (+ 1 height))) + ((? eof-object?) (vertical-space height)) + ((? space?) (loop height)) + (chr (unread-char chr port) (vertical-space height))))) + +(define (read-until-end-of-line port) + "Read white space from PORT until the end of line, included." + (let loop () + (match (read-char port) + (#\newline #t) + ((? eof-object?) #t) + ((? space?) (loop)) + (chr (unread-char chr port))))) + +(define* (read-with-comments port #:key (blank-line? #t)) + "Like 'read', but include <blank> objects when they're encountered. When +BLANK-LINE? is true, assume PORT is at the beginning of a new line." + ;; Note: Instead of implementing this functionality in 'read' proper, which + ;; is the best approach long-term, this code is a layer on top of 'read', + ;; such that we don't have to rely on a specific Guile version. + (define dot (list 'dot)) + (define (dot? x) (eq? x dot)) + + (define (missing-closing-paren-error) + (raise (make-compound-condition + (formatted-message (G_ "unexpected end of file")) + (condition + (&error-location + (location (match (port-filename port) + (#f #f) + (file (location file + (port-line port) + (port-column port)))))) + (&fix-hint + (hint (G_ "Did you forget a closing parenthesis?"))))))) + + (define (reverse/dot lst) + ;; Reverse LST and make it an improper list if it contains DOT. + (let loop ((result '()) + (lst lst)) + (match lst + (() result) + (((? dot?) . rest) + (let ((dotted (reverse rest))) + (set-cdr! (last-pair dotted) (car result)) + dotted)) + ((x . rest) (loop (cons x result) rest))))) + + (let loop ((blank-line? blank-line?) + (return (const 'unbalanced))) + (match (read-char port) + ((? eof-object? eof) + eof) ;oops! + (chr + (cond ((eqv? chr #\newline) + (if blank-line? + (read-vertical-space port) + (loop #t return))) + ((eqv? chr #\page) + ;; Assume that a page break is on a line of its own and read + ;; subsequent white space and newline. + (read-until-end-of-line port) + (page-break)) + ((char-set-contains? char-set:whitespace chr) + (loop blank-line? return)) + ((memv chr '(#\( #\[)) + (let/ec return + (let liip ((lst '())) + (define item + (loop (match lst + (((? blank?) . _) #t) + (_ #f)) + (lambda () + (return (reverse/dot lst))))) + (if (eof-object? item) + (missing-closing-paren-error) + (liip (cons item lst)))))) + ((memv chr '(#\) #\])) + (return)) + ((eq? chr #\') + (list 'quote (loop #f return))) + ((eq? chr #\`) + (list 'quasiquote (loop #f return))) + ((eq? chr #\,) + (list (match (peek-char port) + (#\@ + (read-char port) + 'unquote-splicing) + (_ + 'unquote)) + (loop #f return))) + ((eqv? chr #\;) + (unread-char chr port) + (string->comment (read-line port 'concat) + (not blank-line?))) + (else + (unread-char chr port) + (match (read port) + ((and token '#{.}#) + (if (eq? chr #\.) dot token)) + (token token)))))))) + +(define (read-with-comments/sequence port) + "Read from PORT until the end-of-file is reached and return the list of +expressions and blanks that were read." + (let loop ((lst '()) + (blank-line? #t)) + (match (read-with-comments port #:blank-line? blank-line?) + ((? eof-object?) + (reverse! lst)) + ((? blank? blank) + (loop (cons blank lst) #t)) + (exp + (loop (cons exp lst) #f))))) + + +;;; +;;; Comment-preserving pretty-printer. +;;; + +(define-syntax vhashq + (syntax-rules (quote) + ((_) vlist-null) + ((_ (key (quote (lst ...))) rest ...) + (vhash-consq key '(lst ...) (vhashq rest ...))) + ((_ (key value) rest ...) + (vhash-consq key '((() . value)) (vhashq rest ...))))) + +(define %special-forms + ;; Forms that are indented specially. The number is meant to be understood + ;; like Emacs' 'scheme-indent-function' symbol property. When given an + ;; alist instead of a number, the alist gives "context" in which the symbol + ;; is a special form; for instance, context (modify-phases) means that the + ;; symbol must appear within a (modify-phases ...) expression. + (vhashq + ('begin 1) + ('case 2) + ('cond 1) + ('lambda 2) + ('lambda* 2) + ('match-lambda 1) + ('match-lambda* 2) + ('define 2) + ('define* 2) + ('define-public 2) + ('define*-public 2) + ('define-syntax 2) + ('define-syntax-rule 2) + ('define-module 2) + ('define-gexp-compiler 2) + ('let 2) + ('let* 2) + ('letrec 2) + ('letrec* 2) + ('match 2) + ('when 2) + ('unless 2) + ('package 1) + ('origin 1) + ('modify-inputs 2) + ('modify-phases 2) + ('add-after '(((modify-phases) . 3))) + ('add-before '(((modify-phases) . 3))) + ('replace '(((modify-phases) . 2))) ;different from 'modify-inputs' + ('substitute* 2) + ('substitute-keyword-arguments 2) + ('call-with-input-file 2) + ('call-with-output-file 2) + ('with-output-to-file 2) + ('with-input-from-file 2) + ('with-directory-excursion 2) + + ;; (gnu system) and (gnu services). + ('operating-system 1) + ('bootloader-configuration 1) + ('mapped-device 1) + ('file-system 1) + ('swap-space 1) + ('user-account 1) + ('user-group 1) + ('setuid-program 1) + ('modify-services 2) + + ;; (gnu home). + ('home-environment 1))) + +(define %newline-forms + ;; List heads that must be followed by a newline. The second argument is + ;; the context in which they must appear. This is similar to a special form + ;; of 1, except that indent is 1 instead of 2 columns. + (vhashq + ('arguments '(package)) + ('sha256 '(origin source package)) + ('base32 '(sha256 origin)) + ('git-reference '(uri origin source)) + ('search-paths '(package)) + ('native-search-paths '(package)) + ('search-path-specification '()) + + ('services '(operating-system)) + ('set-xorg-configuration '()) + ('services '(home-environment)))) + +(define (prefix? candidate lst) + "Return true if CANDIDATE is a prefix of LST." + (let loop ((candidate candidate) + (lst lst)) + (match candidate + (() #t) + ((head1 . rest1) + (match lst + (() #f) + ((head2 . rest2) + (and (equal? head1 head2) + (loop rest1 rest2)))))))) + +(define (special-form-lead symbol context) + "If SYMBOL is a special form in the given CONTEXT, return its number of +arguments; otherwise return #f. CONTEXT is a stack of symbols lexically +surrounding SYMBOL." + (match (vhash-assq symbol %special-forms) + (#f #f) + ((_ . alist) + (any (match-lambda + ((prefix . level) + (and (prefix? prefix context) (- level 1)))) + alist)))) + +(define (newline-form? symbol context) + "Return true if parenthesized expressions starting with SYMBOL must be +followed by a newline." + (match (vhash-assq symbol %newline-forms) + (#f #f) + ((_ . prefix) + (prefix? prefix context)))) + +(define (escaped-string str) + "Return STR with backslashes and double quotes escaped. Everything else, in +particular newlines, is left as is." + (list->string + `(#\" + ,@(string-fold-right (lambda (chr lst) + (match chr + (#\" (cons* #\\ #\" lst)) + (#\\ (cons* #\\ #\\ lst)) + (_ (cons chr lst)))) + '() + str) + #\"))) + +(define (string-width str) + "Return the \"width\" of STR--i.e., the width of the longest line of STR." + (apply max (map string-length (string-split str #\newline)))) + +(define (canonicalize-comment comment indent) + "Canonicalize COMMENT, which is to be printed at INDENT, ensuring it has the +\"right\" number of leading semicolons." + (if (zero? indent) + comment ;leave top-level comments unchanged + (let ((line (string-trim-both + (string-trim (comment->string comment) (char-set #\;))))) + (string->comment (string-append + (if (comment-margin? comment) + ";" + (if (string-null? line) + ";;" ;no trailing space + ";; ")) + line "\n") + (comment-margin? comment))))) + +(define %not-newline + (char-set-complement (char-set #\newline))) + +(define (print-multi-line-comment str indent port) + "Print to PORT STR as a multi-line comment, with INDENT spaces preceding +each line except the first one (they're assumed to be already there)." + + ;; While 'read-with-comments' only returns one-line comments, user-provided + ;; comments might span multiple lines, which is why this is necessary. + (let loop ((lst (string-tokenize str %not-newline))) + (match lst + (() #t) + ((last) + (display last port) + (newline port)) + ((head tail ...) + (display head port) + (newline port) + (display (make-string indent #\space) port) + (loop tail))))) + +(define* (pretty-print-with-comments port obj + #:key + (format-comment + (lambda (comment indent) comment)) + (format-vertical-space identity) + (indent 0) + (max-width 78) + (long-list 5)) + "Pretty-print OBJ to PORT, attempting to at most MAX-WIDTH character columns +and assuming the current column is INDENT. Comments present in OBJ are +included in the output. + +Lists longer than LONG-LIST are written as one element per line. Comments are +passed through FORMAT-COMMENT before being emitted; a useful value for +FORMAT-COMMENT is 'canonicalize-comment'. Vertical space is passed through +FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'." + (define (list-of-lists? head tail) + ;; Return true if HEAD and TAIL denote a list of lists--e.g., a list of + ;; 'let' bindings. + (match head + ((thing _ ...) ;proper list + (and (not (memq thing + '(quote quasiquote unquote unquote-splicing))) + (pair? tail))) + (_ #f))) + + (let loop ((indent indent) + (column indent) + (delimited? #t) ;true if comes after a delimiter + (context '()) ;list of "parent" symbols + (obj obj)) + (define (print-sequence context indent column lst delimited?) + (define long? + (> (length lst) long-list)) + + (let print ((lst lst) + (first? #t) + (delimited? delimited?) + (column column)) + (match lst + (() + column) + ((item . tail) + (define newline? + ;; Insert a newline if ITEM is itself a list, or if TAIL is long, + ;; but only if ITEM is not the first item. Also insert a newline + ;; before a keyword. + (and (or (pair? item) long? + (and (keyword? item) + (not (eq? item #:allow-other-keys)))) + (not first?) (not delimited?) + (not (blank? item)))) + + (when newline? + (newline port) + (display (make-string indent #\space) port)) + (let ((column (if newline? indent column))) + (print tail + (keyword? item) ;keep #:key value next to one another + (blank? item) + (loop indent column + (or newline? delimited?) + context + item))))))) + + (define (sequence-would-protrude? indent lst) + ;; Return true if elements of LST written at INDENT would protrude + ;; beyond MAX-WIDTH. This is implemented as a cheap test with false + ;; negatives to avoid actually rendering all of LST. + (find (match-lambda + ((? string? str) + (>= (+ (string-width str) 2 indent) max-width)) + ((? symbol? symbol) + (>= (+ (string-width (symbol->string symbol)) indent) + max-width)) + ((? boolean?) + (>= (+ 2 indent) max-width)) + (() + (>= (+ 2 indent) max-width)) + (_ ;don't know + #f)) + lst)) + + (define (special-form? head) + (special-form-lead head context)) + + (match obj + ((? comment? comment) + (if (comment-margin? comment) + (begin + (display " " port) + (display (comment->string (format-comment comment indent)) + port)) + (begin + ;; When already at the beginning of a line, for example because + ;; COMMENT follows a margin comment, no need to emit a newline. + (unless (= column indent) + (newline port) + (display (make-string indent #\space) port)) + (print-multi-line-comment (comment->string + (format-comment comment indent)) + indent port))) + (display (make-string indent #\space) port) + indent) + ((? vertical-space? space) + (unless delimited? (newline port)) + (let loop ((i (vertical-space-height (format-vertical-space space)))) + (unless (zero? i) + (newline port) + (loop (- i 1)))) + (display (make-string indent #\space) port) + indent) + ((? page-break?) + (unless delimited? (newline port)) + (display #\page port) + (newline port) + (display (make-string indent #\space) port) + indent) + (('quote lst) + (unless delimited? (display " " port)) + (display "'" port) + (loop indent (+ column (if delimited? 1 2)) #t context lst)) + (('quasiquote lst) + (unless delimited? (display " " port)) + (display "`" port) + (loop indent (+ column (if delimited? 1 2)) #t context lst)) + (('unquote lst) + (unless delimited? (display " " port)) + (display "," port) + (loop indent (+ column (if delimited? 1 2)) #t context lst)) + (('unquote-splicing lst) + (unless delimited? (display " " port)) + (display ",@" port) + (loop indent (+ column (if delimited? 2 3)) #t context lst)) + (('gexp lst) + (unless delimited? (display " " port)) + (display "#~" port) + (loop indent (+ column (if delimited? 2 3)) #t context lst)) + (('ungexp obj) + (unless delimited? (display " " port)) + (display "#$" port) + (loop indent (+ column (if delimited? 2 3)) #t context obj)) + (('ungexp-native obj) + (unless delimited? (display " " port)) + (display "#+" port) + (loop indent (+ column (if delimited? 2 3)) #t context obj)) + (('ungexp-splicing lst) + (unless delimited? (display " " port)) + (display "#$@" port) + (loop indent (+ column (if delimited? 3 4)) #t context lst)) + (('ungexp-native-splicing lst) + (unless delimited? (display " " port)) + (display "#+@" port) + (loop indent (+ column (if delimited? 3 4)) #t context lst)) + (((? special-form? head) arguments ...) + ;; Special-case 'let', 'lambda', 'modify-inputs', etc. so the second + ;; and following arguments are less indented. + (let* ((lead (special-form-lead head context)) + (context (cons head context)) + (head (symbol->string head)) + (total (length arguments))) + (unless delimited? (display " " port)) + (display "(" port) + (display head port) + (unless (zero? lead) + (display " " port)) + + ;; Print the first LEAD arguments. + (let* ((indent (+ column 2 + (if delimited? 0 1))) + (column (+ column 1 + (if (zero? lead) 0 1) + (if delimited? 0 1) + (string-length head))) + (initial-indent column)) + (define new-column + (let inner ((n lead) + (arguments (take arguments (min lead total))) + (column column)) + (if (zero? n) + (begin + (newline port) + (display (make-string indent #\space) port) + indent) + (match arguments + (() column) + ((head . tail) + (inner (- n 1) tail + (loop initial-indent column + (= n lead) + context + head))))))) + + ;; Print the remaining arguments. + (let ((column (print-sequence + context indent new-column + (drop arguments (min lead total)) + #t))) + (display ")" port) + (+ column 1))))) + ((head tail ...) + (let* ((overflow? (>= column max-width)) + (column (if overflow? + (+ indent 1) + (+ column (if delimited? 1 2)))) + (newline? (or (newline-form? head context) + (list-of-lists? head tail))) ;'let' bindings + (context (cons head context))) + (if overflow? + (begin + (newline port) + (display (make-string indent #\space) port)) + (unless delimited? (display " " port))) + (display "(" port) + + (let* ((new-column (loop column column #t context head)) + (indent (if (or (>= new-column max-width) + (not (symbol? head)) + (sequence-would-protrude? + (+ new-column 1) tail) + newline?) + column + (+ new-column 1)))) + (when newline? + ;; Insert a newline right after HEAD. + (newline port) + (display (make-string indent #\space) port)) + + (let ((column + (print-sequence context indent + (if newline? indent new-column) + tail newline?))) + (display ")" port) + (+ column 1))))) + (_ + (let* ((str (if (string? obj) + (escaped-string obj) + (object->string obj))) + (len (string-width str))) + (if (and (> (+ column 1 len) max-width) + (not delimited?)) + (begin + (newline port) + (display (make-string indent #\space) port) + (display str port) + (+ indent len)) + (begin + (unless delimited? (display " " port)) + (display str port) + (+ column (if delimited? 0 1) len)))))))) + +(define (object->string* obj indent . args) + "Pretty-print OBJ with INDENT columns as the initial indent. ARGS are +passed as-is to 'pretty-print-with-comments'." + (call-with-output-string + (lambda (port) + (apply pretty-print-with-comments port obj + #:indent indent + args)))) + +(define* (pretty-print-with-comments/splice port lst + #:rest rest) + "Write to PORT the expressions and blanks listed in LST." + (for-each (lambda (exp) + (apply pretty-print-with-comments port exp rest) + (unless (blank? exp) + (newline port))) + lst)) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 75bbb701ae..06d9ad1f0c 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -373,8 +373,19 @@ use '--no-offload' instead~%"))) (first (member arg (targets)))))) (if t (apply values (alist-cons 'target t result) rest) - (leave (G_ "'~a' is not a supported target~%") - arg))))))) + (let ((closest (string-closest arg (targets) + #:threshold 5))) + (report-error + (G_ "'~a' is not a supported cross-compilation target~%") + arg) + (if closest + (display-hint + (format #f (G_ "Did you mean @code{~a}? +Try @option{--list-targets} to view available targets.~%") + closest)) + (display-hint (G_ "\ +Try @option{--list-targets} to view available targets.~%"))) + (exit 1)))))))) (define %standard-native-build-options ;; Build options related to native builds. @@ -389,8 +400,18 @@ use '--no-offload' instead~%"))) (first (member arg (systems)))))) (if s (apply values (alist-cons 'system s result) rest) - (leave (G_ "'~a' is not a supported system~%") - arg))))))) + (let ((closest (string-closest arg (systems) + #:threshold 5))) + (report-error (G_ "'~a' is not a supported system~%") + arg) + (if closest + (display-hint + (format #f (G_ "Did you mean @code{~a}? +Try @option{--list-systems} to view available system types.~%") + closest)) + (display-hint (G_ "\ +Try @option{--list-systems} to view available system types.~%"))) + (exit 1)))))))) ;;; diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 7e4f682053..0c310e3da8 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -29,7 +29,6 @@ #:use-module (guix profiles) #:autoload (guix colors) (supports-hyperlinks? hyperlink) #:autoload (guix openpgp) (openpgp-format-fingerprint) - #:use-module (git) #:autoload (json builder) (scm->json-string) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -148,40 +147,29 @@ Display information about the channels currently in use.\n")) "Display information about the current checkout according to FMT, a symbol denoting the requested format. Exit if the current directory does not lie within a Git checkout." - (let* ((program (car (command-line))) - (directory (catch 'git-error - (lambda () - (repository-discover (dirname program))) - (lambda (key err) - (report-error (G_ "failed to determine origin~%")) - (display-hint (format #f (G_ "Perhaps this + (let* ((program (car (command-line))) + (channel (repository->guix-channel (dirname program)))) + (unless channel + (report-error (G_ "failed to determine origin~%")) + (display-hint (format #f (G_ "Perhaps this @command{guix} command was not obtained with @command{guix pull}? Its version string is ~a.~%") - %guix-version)) - (exit 1)))) - (repository (repository-open directory)) - (head (repository-head repository)) - (commit (oid->string (reference-target head)))) + %guix-version)) + (exit 1)) + (match fmt ('human (format #t (G_ "Git checkout:~%")) - (format #t (G_ " repository: ~a~%") (dirname directory)) - (format #t (G_ " branch: ~a~%") (reference-shorthand head)) - (format #t (G_ " commit: ~a~%") commit)) + (format #t (G_ " repository: ~a~%") (channel-url channel)) + (format #t (G_ " branch: ~a~%") (channel-branch channel)) + (format #t (G_ " commit: ~a~%") (channel-commit channel))) ('channels - (pretty-print `(list ,(channel->code (channel (name 'guix) - (url (dirname directory)) - (commit commit)))))) + (pretty-print `(list ,(channel->code channel)))) ('json - (display (channel->json (channel (name 'guix) - (url (dirname directory)) - (commit commit)))) + (display (channel->json channel)) (newline)) ('recutils - (channel->recutils (channel (name 'guix) - (url (dirname directory)) - (commit commit)) - (current-output-port)))) + (channel->recutils channel (current-output-port)))) (display-package-search-path fmt))) (define* (display-profile-info profile fmt diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 3216235937..2493134470 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -408,7 +408,14 @@ regexps in WHITE-LIST." (lambda () (apply execlp program program args)) (lambda _ - ;; Following established convention, exit with 127 upon ENOENT. + ;; Report the error from here because the parent process cannot + ;; distinguish between the conventional 127 exit code and a process + ;; that exited with 127 for other reasons (e.g., "sh -c xyz"). + (report-error (G_ "~a: command not found~%") program) + (suggest-command-name profile command) + + ;; Following established convention, exit with 127 (aka. EX_NOTFOUND) + ;; upon ENOENT. (primitive-_exit 127)))))) (define (child-shell-environment shell profile manifest) @@ -581,17 +588,6 @@ command name." (display-hint (format #f (G_ "Did you mean '~a'?~%") closest))))))))) -(define (validate-exit-status profile command status) - "When STATUS, an integer as returned by 'waitpid', is 127, raise a \"command -not found\" error. Otherwise return STATUS." - ;; Most likely, exit value 127 means ENOENT. - (when (eqv? (status:exit-val status) 127) - (report-error (G_ "~a: command not found~%") - (first command)) - (suggest-command-name profile command) - (exit 1)) - status) - (define* (launch-environment/fork command profile manifest #:key pure? (white-list '())) "Run COMMAND in a new process with an environment containing PROFILE, with @@ -604,7 +600,7 @@ regexps in WHITE-LIST." #:white-list white-list)) (pid (match (waitpid pid) ((_ . status) - (validate-exit-status profile command status)))))) + status))))) (define* (launch-environment/container #:key command bash user user-mappings profile manifest link-profile? network? @@ -625,9 +621,6 @@ WHILE-LIST." (and (file-exists? (file-system-mapping-source mapping)) (file-system-mapping->bind-mount mapping))) - (define (exit/status* status) - (exit/status (validate-exit-status profile command status))) - (mlet %store-monad ((reqs (inputs->requisites (list (direct-store-path bash) profile)))) (return @@ -684,7 +677,7 @@ WHILE-LIST." '()) (map file-system-mapping->bind-mount mappings)))) - (exit/status* + (exit/status (call-with-container file-systems (lambda () ;; Setup global shell. diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 043273f491..65cd4bdf8b 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2013, 2015-2020, 2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +26,7 @@ profile-generations generation-number) #:autoload (guix scripts package) (delete-generations) + #:autoload (gnu home) (home-generation-base) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) @@ -260,7 +261,8 @@ is deprecated; use '-D'~%")) (filter-map (lambda (root) (and (or (zero? (getuid)) (user-owned? root)) - (generation-profile root))) + (or (generation-profile root) + (home-generation-base root)))) (gc-roots))))) (for-each (lambda (profile) (delete-old-generations store profile pattern)) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 71ab4b4fed..bd3cfd2dc3 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2014, 2020-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net> @@ -25,7 +25,7 @@ (define-module (guix scripts import) #:use-module (guix ui) #:use-module (guix scripts) - #:use-module (guix scripts style) + #:use-module (guix read-print) #:use-module (guix utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index c72dc3caad..9920c3ee62 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org> -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2020, 2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> @@ -108,6 +108,8 @@ run the checkers on all packages.\n")) exclude the specified checkers")) (display (G_ " -n, --no-network only run checkers that do not access the network")) + (display (G_ " + -e, --expression=EXPR consider the package EXPR evaluates to")) (display (G_ " -L, --load-path=DIR prepend DIR to the package module search path")) @@ -161,9 +163,11 @@ run the checkers on all packages.\n")) (exit 0))) (option '(#\l "list-checkers") #f #f (lambda (opt name arg result) - (alist-cons 'list? - #t - result))) + (alist-cons 'list? #t result))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) + (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix lint"))))) @@ -184,8 +188,10 @@ run the checkers on all packages.\n")) (let* ((opts (parse-options)) (args (filter-map (match-lambda - (('argument . value) - value) + (('argument . spec) + (specification->package spec)) + (('expression . exp) + (read/eval-package-expression exp)) (_ #f)) (reverse opts))) (no-checkers (or (assoc-ref opts 'exclude) '())) @@ -219,7 +225,7 @@ run the checkers on all packages.\n")) (fold-packages (lambda (p r) (run-checkers p checkers #:store store)) '())) (else - (for-each (lambda (spec) - (run-checkers (specification->package spec) checkers + (for-each (lambda (package) + (run-checkers package checkers #:store store)) args))))))))) diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index 9fd652beb1..c0b9ea1a28 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -37,468 +37,15 @@ #:use-module (guix utils) #:use-module (guix i18n) #:use-module (guix diagnostics) + #:use-module (guix read-print) #:use-module (ice-9 control) #:use-module (ice-9 match) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) - #:export (pretty-print-with-comments - read-with-comments - canonicalize-comment - - guix-style)) - - -;;; -;;; Comment-preserving reader. -;;; - -;; A comment. -(define-record-type <comment> - (comment str margin?) - comment? - (str comment->string) - (margin? comment-margin?)) - -(define (read-with-comments port) - "Like 'read', but include <comment> objects when they're encountered." - ;; Note: Instead of implementing this functionality in 'read' proper, which - ;; is the best approach long-term, this code is a layer on top of 'read', - ;; such that we don't have to rely on a specific Guile version. - (define dot (list 'dot)) - (define (dot? x) (eq? x dot)) - - (define (reverse/dot lst) - ;; Reverse LST and make it an improper list if it contains DOT. - (let loop ((result '()) - (lst lst)) - (match lst - (() result) - (((? dot?) . rest) - (let ((dotted (reverse rest))) - (set-cdr! (last-pair dotted) (car result)) - dotted)) - ((x . rest) (loop (cons x result) rest))))) - - (let loop ((blank-line? #t) - (return (const 'unbalanced))) - (match (read-char port) - ((? eof-object? eof) - eof) ;oops! - (chr - (cond ((eqv? chr #\newline) - (loop #t return)) - ((char-set-contains? char-set:whitespace chr) - (loop blank-line? return)) - ((memv chr '(#\( #\[)) - (let/ec return - (let liip ((lst '())) - (liip (cons (loop (match lst - (((? comment?) . _) #t) - (_ #f)) - (lambda () - (return (reverse/dot lst)))) - lst))))) - ((memv chr '(#\) #\])) - (return)) - ((eq? chr #\') - (list 'quote (loop #f return))) - ((eq? chr #\`) - (list 'quasiquote (loop #f return))) - ((eq? chr #\,) - (list (match (peek-char port) - (#\@ - (read-char port) - 'unquote-splicing) - (_ - 'unquote)) - (loop #f return))) - ((eqv? chr #\;) - (unread-char chr port) - (comment (read-line port 'concat) - (not blank-line?))) - (else - (unread-char chr port) - (match (read port) - ((and token '#{.}#) - (if (eq? chr #\.) dot token)) - (token token)))))))) - -;;; -;;; Comment-preserving pretty-printer. -;;; - -(define-syntax vhashq - (syntax-rules (quote) - ((_) vlist-null) - ((_ (key (quote (lst ...))) rest ...) - (vhash-consq key '(lst ...) (vhashq rest ...))) - ((_ (key value) rest ...) - (vhash-consq key '((() . value)) (vhashq rest ...))))) - -(define %special-forms - ;; Forms that are indented specially. The number is meant to be understood - ;; like Emacs' 'scheme-indent-function' symbol property. When given an - ;; alist instead of a number, the alist gives "context" in which the symbol - ;; is a special form; for instance, context (modify-phases) means that the - ;; symbol must appear within a (modify-phases ...) expression. - (vhashq - ('begin 1) - ('lambda 2) - ('lambda* 2) - ('match-lambda 1) - ('match-lambda* 2) - ('define 2) - ('define* 2) - ('define-public 2) - ('define*-public 2) - ('define-syntax 2) - ('define-syntax-rule 2) - ('define-module 2) - ('define-gexp-compiler 2) - ('let 2) - ('let* 2) - ('letrec 2) - ('letrec* 2) - ('match 2) - ('when 2) - ('unless 2) - ('package 1) - ('origin 1) - ('operating-system 1) - ('modify-inputs 2) - ('modify-phases 2) - ('add-after '(((modify-phases) . 3))) - ('add-before '(((modify-phases) . 3))) - ('replace '(((modify-phases) . 2))) ;different from 'modify-inputs' - ('substitute* 2) - ('substitute-keyword-arguments 2) - ('call-with-input-file 2) - ('call-with-output-file 2) - ('with-output-to-file 2) - ('with-input-from-file 2))) - -(define %newline-forms - ;; List heads that must be followed by a newline. The second argument is - ;; the context in which they must appear. This is similar to a special form - ;; of 1, except that indent is 1 instead of 2 columns. - (vhashq - ('arguments '(package)) - ('sha256 '(origin source package)) - ('base32 '(sha256 origin)) - ('git-reference '(uri origin source)) - ('search-paths '(package)) - ('native-search-paths '(package)) - ('search-path-specification '()))) - -(define (prefix? candidate lst) - "Return true if CANDIDATE is a prefix of LST." - (let loop ((candidate candidate) - (lst lst)) - (match candidate - (() #t) - ((head1 . rest1) - (match lst - (() #f) - ((head2 . rest2) - (and (equal? head1 head2) - (loop rest1 rest2)))))))) - -(define (special-form-lead symbol context) - "If SYMBOL is a special form in the given CONTEXT, return its number of -arguments; otherwise return #f. CONTEXT is a stack of symbols lexically -surrounding SYMBOL." - (match (vhash-assq symbol %special-forms) - (#f #f) - ((_ . alist) - (any (match-lambda - ((prefix . level) - (and (prefix? prefix context) (- level 1)))) - alist)))) - -(define (newline-form? symbol context) - "Return true if parenthesized expressions starting with SYMBOL must be -followed by a newline." - (match (vhash-assq symbol %newline-forms) - (#f #f) - ((_ . prefix) - (prefix? prefix context)))) - -(define (escaped-string str) - "Return STR with backslashes and double quotes escaped. Everything else, in -particular newlines, is left as is." - (list->string - `(#\" - ,@(string-fold-right (lambda (chr lst) - (match chr - (#\" (cons* #\\ #\" lst)) - (#\\ (cons* #\\ #\\ lst)) - (_ (cons chr lst)))) - '() - str) - #\"))) - -(define (string-width str) - "Return the \"width\" of STR--i.e., the width of the longest line of STR." - (apply max (map string-length (string-split str #\newline)))) - -(define (canonicalize-comment c) - "Canonicalize comment C, ensuring it has the \"right\" number of leading -semicolons." - (let ((line (string-trim-both - (string-trim (comment->string c) (char-set #\;))))) - (comment (string-append - (if (comment-margin? c) - ";" - (if (string-null? line) - ";;" ;no trailing space - ";; ")) - line "\n") - (comment-margin? c)))) - -(define* (pretty-print-with-comments port obj - #:key - (format-comment identity) - (indent 0) - (max-width 78) - (long-list 5)) - "Pretty-print OBJ to PORT, attempting to at most MAX-WIDTH character columns -and assuming the current column is INDENT. Comments present in OBJ are -included in the output. - -Lists longer than LONG-LIST are written as one element per line. Comments are -passed through FORMAT-COMMENT before being emitted; a useful value for -FORMAT-COMMENT is 'canonicalize-comment'." - (define (list-of-lists? head tail) - ;; Return true if HEAD and TAIL denote a list of lists--e.g., a list of - ;; 'let' bindings. - (match head - ((thing _ ...) ;proper list - (and (not (memq thing - '(quote quasiquote unquote unquote-splicing))) - (pair? tail))) - (_ #f))) - - (let loop ((indent indent) - (column indent) - (delimited? #t) ;true if comes after a delimiter - (context '()) ;list of "parent" symbols - (obj obj)) - (define (print-sequence context indent column lst delimited?) - (define long? - (> (length lst) long-list)) - - (let print ((lst lst) - (first? #t) - (delimited? delimited?) - (column column)) - (match lst - (() - column) - ((item . tail) - (define newline? - ;; Insert a newline if ITEM is itself a list, or if TAIL is long, - ;; but only if ITEM is not the first item. Also insert a newline - ;; before a keyword. - (and (or (pair? item) long? - (and (keyword? item) - (not (eq? item #:allow-other-keys)))) - (not first?) (not delimited?) - (not (comment? item)))) - - (when newline? - (newline port) - (display (make-string indent #\space) port)) - (let ((column (if newline? indent column))) - (print tail - (keyword? item) ;keep #:key value next to one another - (comment? item) - (loop indent column - (or newline? delimited?) - context - item))))))) - - (define (sequence-would-protrude? indent lst) - ;; Return true if elements of LST written at INDENT would protrude - ;; beyond MAX-WIDTH. This is implemented as a cheap test with false - ;; negatives to avoid actually rendering all of LST. - (find (match-lambda - ((? string? str) - (>= (+ (string-width str) 2 indent) max-width)) - ((? symbol? symbol) - (>= (+ (string-width (symbol->string symbol)) indent) - max-width)) - ((? boolean?) - (>= (+ 2 indent) max-width)) - (() - (>= (+ 2 indent) max-width)) - (_ ;don't know - #f)) - lst)) - - (define (special-form? head) - (special-form-lead head context)) - - (match obj - ((? comment? comment) - (if (comment-margin? comment) - (begin - (display " " port) - (display (comment->string (format-comment comment)) - port)) - (begin - ;; When already at the beginning of a line, for example because - ;; COMMENT follows a margin comment, no need to emit a newline. - (unless (= column indent) - (newline port) - (display (make-string indent #\space) port)) - (display (comment->string (format-comment comment)) - port))) - (display (make-string indent #\space) port) - indent) - (('quote lst) - (unless delimited? (display " " port)) - (display "'" port) - (loop indent (+ column (if delimited? 1 2)) #t context lst)) - (('quasiquote lst) - (unless delimited? (display " " port)) - (display "`" port) - (loop indent (+ column (if delimited? 1 2)) #t context lst)) - (('unquote lst) - (unless delimited? (display " " port)) - (display "," port) - (loop indent (+ column (if delimited? 1 2)) #t context lst)) - (('unquote-splicing lst) - (unless delimited? (display " " port)) - (display ",@" port) - (loop indent (+ column (if delimited? 2 3)) #t context lst)) - (('gexp lst) - (unless delimited? (display " " port)) - (display "#~" port) - (loop indent (+ column (if delimited? 2 3)) #t context lst)) - (('ungexp obj) - (unless delimited? (display " " port)) - (display "#$" port) - (loop indent (+ column (if delimited? 2 3)) #t context obj)) - (('ungexp-native obj) - (unless delimited? (display " " port)) - (display "#+" port) - (loop indent (+ column (if delimited? 2 3)) #t context obj)) - (('ungexp-splicing lst) - (unless delimited? (display " " port)) - (display "#$@" port) - (loop indent (+ column (if delimited? 3 4)) #t context lst)) - (('ungexp-native-splicing lst) - (unless delimited? (display " " port)) - (display "#+@" port) - (loop indent (+ column (if delimited? 3 4)) #t context lst)) - (((? special-form? head) arguments ...) - ;; Special-case 'let', 'lambda', 'modify-inputs', etc. so the second - ;; and following arguments are less indented. - (let* ((lead (special-form-lead head context)) - (context (cons head context)) - (head (symbol->string head)) - (total (length arguments))) - (unless delimited? (display " " port)) - (display "(" port) - (display head port) - (unless (zero? lead) - (display " " port)) - - ;; Print the first LEAD arguments. - (let* ((indent (+ column 2 - (if delimited? 0 1))) - (column (+ column 1 - (if (zero? lead) 0 1) - (if delimited? 0 1) - (string-length head))) - (initial-indent column)) - (define new-column - (let inner ((n lead) - (arguments (take arguments (min lead total))) - (column column)) - (if (zero? n) - (begin - (newline port) - (display (make-string indent #\space) port) - indent) - (match arguments - (() column) - ((head . tail) - (inner (- n 1) tail - (loop initial-indent column - (= n lead) - context - head))))))) - - ;; Print the remaining arguments. - (let ((column (print-sequence - context indent new-column - (drop arguments (min lead total)) - #t))) - (display ")" port) - (+ column 1))))) - ((head tail ...) - (let* ((overflow? (>= column max-width)) - (column (if overflow? - (+ indent 1) - (+ column (if delimited? 1 2)))) - (newline? (or (newline-form? head context) - (list-of-lists? head tail))) ;'let' bindings - (context (cons head context))) - (if overflow? - (begin - (newline port) - (display (make-string indent #\space) port)) - (unless delimited? (display " " port))) - (display "(" port) - - (let* ((new-column (loop column column #t context head)) - (indent (if (or (>= new-column max-width) - (not (symbol? head)) - (sequence-would-protrude? - (+ new-column 1) tail) - newline?) - column - (+ new-column 1)))) - (when newline? - ;; Insert a newline right after HEAD. - (newline port) - (display (make-string indent #\space) port)) - - (let ((column - (print-sequence context indent - (if newline? indent new-column) - tail newline?))) - (display ")" port) - (+ column 1))))) - (_ - (let* ((str (if (string? obj) - (escaped-string obj) - (object->string obj))) - (len (string-width str))) - (if (and (> (+ column 1 len) max-width) - (not delimited?)) - (begin - (newline port) - (display (make-string indent #\space) port) - (display str port) - (+ indent len)) - (begin - (unless delimited? (display " " port)) - (display str port) - (+ column (if delimited? 0 1) len)))))))) - -(define (object->string* obj indent . args) - (call-with-output-string - (lambda (port) - (apply pretty-print-with-comments port obj - #:indent indent - args)))) + #:export (guix-style)) ;;; @@ -561,7 +108,7 @@ bailing out~%") (exp exp) (inputs inputs)) (match exp - (((? comment? head) . rest) + (((? blank? head) . rest) (loop (cons head result) rest inputs)) ((head . rest) (match inputs @@ -769,7 +316,8 @@ PACKAGE." (object->string* exp (location-column (package-definition-location package)) - #:format-comment canonicalize-comment))))) + #:format-comment canonicalize-comment + #:format-vertical-space canonicalize-vertical-space))))) (define (package-location<? p1 p2) "Return true if P1's location is \"before\" P2's." @@ -782,6 +330,21 @@ PACKAGE." ;;; +;;; Whole-file formatting. +;;; + +(define* (format-whole-file file #:rest rest) + "Reformat all of FILE." + (let ((lst (call-with-input-file file read-with-comments/sequence))) + (with-atomic-file-output file + (lambda (port) + (apply pretty-print-with-comments/splice port lst + #:format-comment canonicalize-comment + #:format-vertical-space canonicalize-vertical-space + rest))))) + + +;;; ;;; Options. ;;; @@ -797,6 +360,9 @@ PACKAGE." (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) + (option '(#\f "whole-file") #f #f + (lambda (opt name arg result) + (alist-cons 'whole-file? #t result))) (option '(#\S "styling") #t #f (lambda (opt name arg result) (alist-cons 'styling-procedure @@ -852,6 +418,9 @@ Update package definitions to the latest style.\n")) of 'silent', 'safe', or 'always'")) (newline) (display (G_ " + -f, --whole-file format the entire contents of the given file(s)")) + (newline) + (display (G_ " -h, --help display this help and exit")) (display (G_ " -V, --version display version information and exit")) @@ -878,27 +447,35 @@ Update package definitions to the latest style.\n")) #:build-options? #f)) (let* ((opts (parse-options)) - (packages (filter-map (match-lambda - (('argument . spec) - (specification->package spec)) - (('expression . str) - (read/eval str)) - (_ #f)) - opts)) (edit (if (assoc-ref opts 'dry-run?) edit-expression/dry-run edit-expression)) (style (assoc-ref opts 'styling-procedure)) (policy (assoc-ref opts 'input-simplification-policy))) (with-error-handling - (for-each (lambda (package) - (style package #:policy policy - #:edit-expression edit)) - ;; Sort package by source code location so that we start editing - ;; files from the bottom and going upward. That way, the - ;; 'location' field of <package> records is not invalidated as - ;; we modify files. - (sort (if (null? packages) - (fold-packages cons '() #:select? (const #t)) - packages) - (negate package-location<?)))))) + (if (assoc-ref opts 'whole-file?) + (let ((files (filter-map (match-lambda + (('argument . file) file) + (_ #f)) + opts))) + (unless (eq? format-package-definition style) + (warning (G_ "'--styling' option has no effect in whole-file mode~%"))) + (for-each format-whole-file files)) + (let ((packages (filter-map (match-lambda + (('argument . spec) + (specification->package spec)) + (('expression . str) + (read/eval str)) + (_ #f)) + opts))) + (for-each (lambda (package) + (style package #:policy policy + #:edit-expression edit)) + ;; Sort package by source code location so that we start + ;; editing files from the bottom and going upward. That + ;; way, the 'location' field of <package> records is not + ;; invalidated as we modify files. + (sort (if (null? packages) + (fold-packages cons '() #:select? (const #t)) + packages) + (negate package-location<?)))))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index bfde0a88ca..be6e839941 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -91,7 +91,6 @@ #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:export (guix-system - read-operating-system service-node-type shepherd-service-node-type)) @@ -107,10 +106,6 @@ (gnu services) (gnu system shadow)))) -(define (read-operating-system file) - "Read the operating-system declaration from FILE and return it." - (load* file %user-module)) - ;;; ;;; Installation. diff --git a/guix/self.scm b/guix/self.scm index d1ccec8a49..fc80e78804 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -929,6 +929,7 @@ itself." (('guix 'scripts 'deploy) #t) (('guix 'scripts 'home . _) #t) (('guix 'scripts 'import . _) #t) + (('guix 'scripts 'gc) #t) ;autoloads (gnu home) (('guix 'pack) #t) (_ #f)) (scheme-modules* source "guix/scripts")) diff --git a/guix/ssh.scm b/guix/ssh.scm index a6f0f2eb96..1b825a2573 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -162,6 +162,10 @@ server at '~a': ~a") ('success (session-set! session 'timeout timeout) session) + ('again + (raise (formatted-message (G_ "timeout while connecting \ +to SSH server at '~a'") + (session-get session 'host)))) (x (match (userauth-gssapi! session) ('success diff --git a/guix/tests/git.scm b/guix/tests/git.scm index 94f1021c79..d51e49e514 100644 --- a/guix/tests/git.scm +++ b/guix/tests/git.scm @@ -73,6 +73,7 @@ Return DIRECTORY on success." (mkdir-p (dirname file)) (call-with-output-file file (lambda (port) + (set-port-encoding! port "UTF-8") (display (if (string? contents) contents (with-repository directory repository diff --git a/guix/utils.scm b/guix/utils.scm index 329ef62dde..aca0af4e4b 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -15,6 +15,7 @@ ;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com> ;;; Copyright © 2022 Taiju HIGASHI <higashi@taiju.info> ;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org> +;;; Copyright © 2022 Antero Mejr <antero@mailbox.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -101,8 +102,10 @@ target-ppc64le? target-powerpc? target-riscv64? + target-mips64el? target-64bit? ar-for-target + as-for-target cc-for-target cxx-for-target ld-for-target @@ -732,6 +735,10 @@ architecture (x86_64)?" "Is the architecture of TARGET a 'riscv64' machine?" (string-prefix? "riscv64" target)) +(define* (target-mips64el? #:optional (target (or (%current-target-system) + (%current-system)))) + (string-prefix? "mips64el-" target)) + (define* (target-64bit? #:optional (system (or (%current-target-system) (%current-system)))) (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" @@ -742,6 +749,11 @@ architecture (x86_64)?" (string-append target "-ar") "ar")) +(define* (as-for-target #:optional (target (%current-target-system))) + (if target + (string-append target "-as") + "as")) + (define* (cc-for-target #:optional (target (%current-target-system))) (if target (string-append target "-gcc") |