From 78b3748c1c5446f19e7a74ec424d61a7826fc843 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Sat, 23 Mar 2019 19:18:31 +0100 Subject: guix: dune-build-system: Add a package parameter. * guix/build-system/dune.scm: Add a package parameter. * guix/build/dune.scm (build, test, install): Use it. * doc/guix.texi: Document it. --- guix/build-system/dune.scm | 2 ++ guix/build/dune-build-system.scm | 17 ++++++++++------- 2 files changed, 12 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/build-system/dune.scm b/guix/build-system/dune.scm index 8bd41c89f0..6a2f3d16de 100644 --- a/guix/build-system/dune.scm +++ b/guix/build-system/dune.scm @@ -87,6 +87,7 @@ (build-flags ''()) (out-of-source? #t) (jbuild? #f) + (package #f) (tests? #t) (test-flags ''()) (test-target "test") @@ -125,6 +126,7 @@ provides a 'setup.ml' file as its build system." #:build-flags ,build-flags #:out-of-source? ,out-of-source? #:jbuild? ,jbuild? + #:package ,package #:tests? ,tests? #:test-target ,test-target #:install-target ,install-target diff --git a/guix/build/dune-build-system.scm b/guix/build/dune-build-system.scm index 00b0c7c406..7e2ec1e3e1 100644 --- a/guix/build/dune-build-system.scm +++ b/guix/build/dune-build-system.scm @@ -31,27 +31,30 @@ ;; Code: (define* (build #:key (build-flags '()) (jbuild? #f) - (use-make? #f) #:allow-other-keys) + (use-make? #f) (package #f) #:allow-other-keys) "Build the given package." (let ((program (if jbuild? "jbuilder" "dune"))) - (apply invoke program "build" "@install" build-flags)) + (apply invoke program "build" "@install" + (append (if package (list "-p" package) '()) build-flags))) #t) (define* (check #:key (test-flags '()) (test-target "test") tests? - (jbuild? #f) #:allow-other-keys) + (jbuild? #f) (package #f) #:allow-other-keys) "Test the given package." (when tests? (let ((program (if jbuild? "jbuilder" "dune"))) - (apply invoke program "runtest" test-target test-flags))) + (apply invoke program "runtest" test-target + (append (if package (list "-p" package) '()) test-flags)))) #t) (define* (install #:key outputs (install-target "install") (jbuild? #f) - #:allow-other-keys) + (package #f) #:allow-other-keys) "Install the given package." (let ((out (assoc-ref outputs "out")) (program (if jbuild? "jbuilder" "dune"))) - (invoke program install-target "--prefix" out "--libdir" - (string-append out "/lib/ocaml/site-lib"))) + (apply invoke program install-target "--prefix" out "--libdir" + (string-append out "/lib/ocaml/site-lib") + (if package (list package) '()))) #t) (define %standard-phases -- cgit v1.2.3 From 94aeec0aef03ab44e41bfc3e77c3b623cb3d607c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 23 Mar 2019 23:53:55 +0100 Subject: ui: Bypass Texinfo parsing and rendering for searches. This makes search queries such as: LANGUAGE=fr guix package -s utilitaire -s recherche about 6 times faster. * guix/ui.scm (%package-metrics): Do not use 'package-synopsis-string' and 'package-description-string' to bypass Texinfo parsing and rendering. --- guix/ui.scm | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 2fc001d2eb..0070301c47 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1329,8 +1329,14 @@ score, the more relevant OBJ is to REGEXPS." ;; Metrics used to compute the "relevance score" of a package against a set ;; of regexps. `((,package-name . 4) - (,package-synopsis-string . 3) - (,package-description-string . 2) + + ;; Match regexps on the raw Texinfo since formatting it is quite expensive + ;; and doesn't have much of an effect on search results. + (,(lambda (package) + (and=> (package-synopsis package) P_)) . 3) + (,(lambda (package) + (and=> (package-description package) P_)) . 2) + (,(lambda (type) (match (and=> (package-location type) location-file) ((? string? file) (basename file ".scm")) -- cgit v1.2.3 From abd4d6b33dba4de228e90ad15a8efb456fcf7b6e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 22 Mar 2019 14:02:00 +0100 Subject: records: Allow thunked fields to refer to 'this-record'. * guix/records.scm (this-record): New syntax parameter. (make-syntactic-constructor)[wrap-field-value]: When F is thunked, return a one-argument lambda instead of a thunk, and parameterize THIS-RECORD. (define-record-type*)[thunked-field-accessor-definition]: Pass X to (real-get X). * tests/records.scm ("define-record-type* & thunked & this-record") ("define-record-type* & thunked & default & this-record") ("define-record-type* & thunked & inherit & this-record"): New tests. --- guix/records.scm | 24 ++++++++++++++++++++++-- tests/records.scm | 40 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 62 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/records.scm b/guix/records.scm index 0649c90ea3..244b124098 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -25,6 +25,8 @@ #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) #:export (define-record-type* + this-record + alist->record object->fields recutils->alist @@ -93,6 +95,17 @@ interface\" (ABI) for TYPE is equal to COOKIE." (() #t))))))) +(define-syntax-parameter this-record + (lambda (s) + "Return the record being defined. This macro may only be used in the +context of the definition of a thunked field." + (syntax-case s () + (id + (identifier? #'id) + (syntax-violation 'this-record + "cannot be used outside of a record instantiation" + #'id))))) + (define-syntax make-syntactic-constructor (syntax-rules () "Make the syntactic constructor NAME for TYPE, that calls CTOR, and @@ -148,7 +161,14 @@ of TYPE matches the expansion-time ABI." (define (wrap-field-value f value) (cond ((thunked-field? f) - #`(lambda () #,value)) + #`(lambda (x) + (syntax-parameterize ((this-record + (lambda (s) + (syntax-case s () + (id + (identifier? #'id) + #'x))))) + #,value))) ((delayed-field? f) #`(delay #,value)) (else value))) @@ -308,7 +328,7 @@ inherited." (with-syntax ((real-get (wrapped-field-accessor-name field))) #'(define-inlinable (get x) ;; The real value of that field is a thunk, so call it. - ((real-get x))))))) + ((real-get x) x)))))) (define (delayed-field-accessor-definition field) ;; Return the real accessor for FIELD, which is assumed to be a diff --git a/tests/records.scm b/tests/records.scm index d9469a78bd..45614093a0 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -170,6 +170,46 @@ (parameterize ((mark (cons 'a 'b))) (eq? (foo-bar y) (mark))))))) +(test-assert "define-record-type* & thunked & this-record" + (begin + (define-record-type* foo make-foo + foo? + (bar foo-bar) + (baz foo-baz (thunked))) + + (let ((x (foo (bar 40) + (baz (+ (foo-bar this-record) 2))))) + (and (= 40 (foo-bar x)) + (= 42 (foo-baz x)))))) + +(test-assert "define-record-type* & thunked & default & this-record" + (begin + (define-record-type* foo make-foo + foo? + (bar foo-bar) + (baz foo-baz (thunked) + (default (+ (foo-bar this-record) 2)))) + + (let ((x (foo (bar 40)))) + (and (= 40 (foo-bar x)) + (= 42 (foo-baz x)))))) + +(test-assert "define-record-type* & thunked & inherit & this-record" + (begin + (define-record-type* foo make-foo + foo? + (bar foo-bar) + (baz foo-baz (thunked) + (default (+ (foo-bar this-record) 2)))) + + (let* ((x (foo (bar 40))) + (y (foo (inherit x) (bar -2))) + (z (foo (inherit x) (baz -2)))) + (and (= -2 (foo-bar y)) + (= 0 (foo-baz y)) + (= 40 (foo-bar z)) + (= -2 (foo-baz z)))))) + (test-assert "define-record-type* & delayed" (begin (define-record-type* foo make-foo -- cgit v1.2.3 From e6301fb76d0a8d931ece2e18d197e3c2cc53fc6c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 26 Mar 2019 10:22:15 +0100 Subject: packages: Adjust to new calling convention for "thunked" fields. Fixes . This is a followup to abd4d6b33dba4de228e90ad15a8efb456fcf7b6e. * guix/packages.scm (package->bag): Adjust calls to INPUTS, PROPAGATED-INPUTS, NATIVE-INPUTS, and ARGS, passing them SELF as an argument. * gnu/packages/gnucash.scm (gnucash)[arguments]: Use (package-inputs this-record) intead of (inputs). * gnu/packages/version-control.scm (git)[arguments]: Likewise. --- gnu/packages/gnucash.scm | 5 +++-- gnu/packages/version-control.scm | 5 +++-- guix/packages.scm | 17 +++++++++-------- 3 files changed, 15 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/gnu/packages/gnucash.scm b/gnu/packages/gnucash.scm index 2207dd3fae..84b244cdd9 100644 --- a/gnu/packages/gnucash.scm +++ b/gnu/packages/gnucash.scm @@ -27,6 +27,7 @@ #:use-module (guix download) #:use-module (guix build-system gnu) #:use-module (guix build-system cmake) + #:use-module ((guix records) #:select (this-record)) #:use-module (gnu packages) #:use-module (gnu packages autotools) #:use-module (gnu packages base) @@ -165,14 +166,14 @@ ,@(transitive-input-references 'inputs (map (lambda (l) - (assoc l (inputs))) + (assoc l (package-inputs this-record))) '("perl-finance-quote" "perl-date-manip")))) (list ,@(transitive-input-references 'inputs (map (lambda (l) - (assoc l (inputs))) + (assoc l (package-inputs this-record))) '("perl-finance-quote"))))))))) '("gnucash" "gnc-fq-check" diff --git a/gnu/packages/version-control.scm b/gnu/packages/version-control.scm index 9a6f96ce14..fe9b64ba5c 100644 --- a/gnu/packages/version-control.scm +++ b/gnu/packages/version-control.scm @@ -51,6 +51,7 @@ #:use-module (guix build-system haskell) #:use-module (guix build-system python) #:use-module (guix build-system trivial) + #:use-module ((guix records) #:select (this-record)) #:use-module (gnu packages apr) #:use-module (gnu packages autotools) #:use-module (gnu packages documentation) @@ -408,7 +409,7 @@ as well as the classic centralized workflow.") ,@(transitive-input-references 'inputs (map (lambda (l) - (assoc l (inputs))) + (assoc l (package-inputs this-record))) '("perl-authen-sasl" "perl-net-smtp-ssl" "perl-io-socket-ssl"))))))) @@ -421,7 +422,7 @@ as well as the classic centralized workflow.") ,@(transitive-input-references 'inputs (map (lambda (l) - (assoc l (inputs))) + (assoc l (package-inputs this-record))) '("perl-cgi"))))))) ;; Tell 'git-submodule' where Perl is. diff --git a/guix/packages.scm b/guix/packages.scm index d20a2562c3..9d83de3d48 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1025,9 +1025,10 @@ and return it." (match (if graft? (or (package-replacement package) package) package) - (($ name version source build-system - args inputs propagated-inputs native-inputs - self-native-input? outputs) + ((and self + ($ name version source build-system + args inputs propagated-inputs native-inputs + self-native-input? outputs)) ;; Even though we prefer to use "@" to separate the package ;; name from the package version in various user-facing parts ;; of Guix, checkStoreName (in nix/libstore/store-api.cc) @@ -1036,15 +1037,15 @@ and return it." #:system system #:target target #:source source - #:inputs (append (inputs) - (propagated-inputs)) + #:inputs (append (inputs self) + (propagated-inputs self)) #:outputs outputs #:native-inputs `(,@(if (and target self-native-input?) - `(("self" ,package)) + `(("self" ,self)) '()) - ,@(native-inputs)) - #:arguments (args)) + ,@(native-inputs self)) + #:arguments (args self)) (raise (if target (condition (&package-cross-build-system-error -- cgit v1.2.3 From 8a9922bdee875b3b5e1d928fc8e2121ffa99663a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 26 Mar 2019 12:12:41 +0100 Subject: environment: Use (gnu build accounts) for /etc/passwd handling. * guix/scripts/environment.scm (launch-environment/container): Remove call to 'mock-passwd'; instantiate a instead. Call 'write-passwd' to write the pasword database instead of using custom code. (mock-passwd): Remove. * tests/guix-environment-container.sh: Test 'getpwuid'. --- guix/scripts/environment.scm | 54 +++++++++---------------------------- tests/guix-environment-container.sh | 6 +++++ 2 files changed, 19 insertions(+), 41 deletions(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 63f6129279..597a5b4ab1 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -33,6 +33,7 @@ #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (gnu build linux-container) + #:use-module (gnu build accounts) #:use-module (gnu system linux-container) #:use-module (gnu system file-systems) #:use-module (gnu packages) @@ -458,10 +459,17 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (return (let* ((cwd (getcwd)) (home (getenv "HOME")) - (passwd (mock-passwd (getpwuid (getuid)) - user - bash)) - (home-dir (passwd:dir passwd)) + (passwd (let ((pwd (getpwuid (getuid)))) + (password-entry + (name (or user (passwd:name pwd))) + (real-name (if user + "" + (passwd:gecos pwd))) + (uid 0) (gid 0) (shell bash) + (directory (if user + (string-append "/home/" user) + (passwd:dir pwd)))))) + (home-dir (password-entry-directory passwd)) ;; Bind-mount all requisite store items, user-specified mappings, ;; /bin/sh, the current working directory, and possibly networking ;; configuration files within the container. @@ -519,17 +527,7 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from ;; to read it, such as 'git clone' over SSH, a valid use-case when ;; sharing the host's network namespace. (mkdir-p "/etc") - (call-with-output-file "/etc/passwd" - (lambda (port) - (display (string-join (list (passwd:name passwd) - "x" ; but there is no shadow - "0" "0" ; user is now root - (passwd:gecos passwd) - (passwd:dir passwd) - bash) - ":") - port) - (newline port))) + (write-passwd (list passwd)) ;; For convenience, start in the user's current working ;; directory rather than the root directory. @@ -543,32 +541,6 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (delq 'net %namespaces) ; share host network %namespaces))))))) -(define (mock-passwd passwd user-override shell) - "Generate mock information for '/etc/passwd'. If USER-OVERRIDE is not '#f', -it is expected to be a string representing the mock username; it will produce -a user of that name, with a home directory of '/home/USER-OVERRIDE', and no -GECOS field. If USER-OVERRIDE is '#f', data will be inherited from PASSWD. -In either case, the shadow password and UID/GID are cleared, since the user -runs as root within the container. SHELL will always be used in place of the -shell in PASSWD. - -The resulting vector is suitable for use with Guile's POSIX user procedures. - -See passwd(5) for more information each of the fields." - (if user-override - (vector - user-override - "x" "0" "0" ;; no shadow, user is now root - "" ;; no personal information - (user-override-home user-override) - shell) - (vector - (passwd:name passwd) - "x" "0" "0" ;; no shadow, user is now root - (passwd:gecos passwd) - (passwd:dir passwd) - shell))) - (define (user-override-home user) "Return home directory for override user USER." (string-append "/home/" user)) diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh index a2da9a0773..059c4d9213 100644 --- a/tests/guix-environment-container.sh +++ b/tests/guix-environment-container.sh @@ -44,6 +44,12 @@ else test $? = 42 fi +if test "x$USER" = "x"; then USER="`id -un`"; fi + +# Check whether /etc/passwd is valid. +guix environment -C --ad-hoc --bootstrap guile-bootstrap \ + -- guile -c "(exit (string=? \"$USER\" (passwd:name (getpwuid (getuid)))))" + # Make sure file-not-found errors in mounts are reported. if guix environment --container --ad-hoc --bootstrap guile-bootstrap \ --expose=/does-not-exist -- guile -c 1 2> "$tmpdir/error" -- cgit v1.2.3 From 952afb6f8c209692e52f9561965ee39e143e1d88 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 26 Mar 2019 18:07:58 +0100 Subject: environment: Create /etc/group in containers. Reported by Pierre Neidhardt . * guix/scripts/environment.scm (launch-environment/container): Create GROUPS and call 'write-group'. * tests/guix-environment-container.sh: Test it. --- guix/scripts/environment.scm | 4 ++++ tests/guix-environment-container.sh | 8 +++++++- 2 files changed, 11 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 597a5b4ab1..c27edc7982 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -469,6 +469,9 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (directory (if user (string-append "/home/" user) (passwd:dir pwd)))))) + (groups (list (group-entry (name "users") (gid 0)) + (group-entry (gid 65534) ;the overflow GID + (name "overflow")))) (home-dir (password-entry-directory passwd)) ;; Bind-mount all requisite store items, user-specified mappings, ;; /bin/sh, the current working directory, and possibly networking @@ -528,6 +531,7 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from ;; sharing the host's network namespace. (mkdir-p "/etc") (write-passwd (list passwd)) + (write-group groups) ;; For convenience, start in the user's current working ;; directory rather than the root directory. diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh index 059c4d9213..f2221af95b 100644 --- a/tests/guix-environment-container.sh +++ b/tests/guix-environment-container.sh @@ -46,9 +46,15 @@ fi if test "x$USER" = "x"; then USER="`id -un`"; fi -# Check whether /etc/passwd is valid. +# Check whether /etc/passwd and /etc/group are valid. guix environment -C --ad-hoc --bootstrap guile-bootstrap \ -- guile -c "(exit (string=? \"$USER\" (passwd:name (getpwuid (getuid)))))" +guix environment -C --ad-hoc --bootstrap guile-bootstrap \ + -- guile -c '(exit (string? (group:name (getgrgid (getgid)))))' +guix environment -C --ad-hoc --bootstrap guile-bootstrap \ + -- guile -c '(use-modules (srfi srfi-1)) + (exit (every group:name + (map getgrgid (vector->list (getgroups)))))' # Make sure file-not-found errors in mounts are reported. if guix environment --container --ad-hoc --bootstrap guile-bootstrap \ -- cgit v1.2.3 From 9e5f2060ad9204def8d1eb249f053f1fd0bbf212 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 27 Mar 2019 11:52:47 +0100 Subject: scripts: Skip 'guix pull' suggestion when running code from a checkout. * guix/scripts.scm (warn-about-old-distro): Do not warn when GUIX_UNINSTALLED is set. --- guix/scripts.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts.scm b/guix/scripts.scm index 75d801a466..e4b11d295d 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -173,7 +173,8 @@ Show what and how will/would be built." "Your Guix installation is ~a days old.\n" (seconds->days age)) (seconds->days age))) - (when (or (not age) (>= age old)) + (when (and (or (not age) (>= age old)) + (not (getenv "GUIX_UNINSTALLED"))) (warning (G_ "Consider running 'guix pull' followed by '~a' to get up-to-date packages and security updates.\n") suggested-command) -- cgit v1.2.3 From 1ee3d2dcb8892b2ed1a0212fdd6ac2c47f2c8da2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 27 Mar 2019 14:42:07 +0100 Subject: upstream: 'package-update' returns the object. Fixes a regression introduced in abd4d6b33dba4de228e90ad15a8efb456fcf7b6e, where CHANGES would no longer be a thunk. Reported by Ricardo Wurmus. * guix/upstream.scm (package-update/url-fetch): Return SOURCE as the third value instead of CHANGES. * guix/scripts/refresh.scm (update-package): Adjust accordingly. --- guix/scripts/refresh.scm | 4 ++-- guix/upstream.scm | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 5b0f345cde..6d77e2642b 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -297,7 +297,7 @@ KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed values: 'interactive' (default), 'always', and 'never'. When WARN? is true, warn about packages that have no matching updater." (if (lookup-updater package updaters) - (let-values (((version tarball changes) + (let-values (((version tarball source) (package-update store package updaters #:key-download key-download)) ((loc) @@ -330,7 +330,7 @@ warn about packages that have no matching updater." (G_ "~a: consider removing this propagated input: ~a~%"))) (package-name package) (upstream-input-change-name change))) - (changes)) + (upstream-source-input-changes source)) (let ((hash (call-with-input-file tarball port-sha256))) (update-package-source package version hash))) diff --git a/guix/upstream.scm b/guix/upstream.scm index 55683dd9b7..2c70b3422d 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -344,10 +344,10 @@ values: the item from LST1 and the item from LST2 that match PRED." (define* (package-update/url-fetch store package source #:key key-download) - "Return the version, tarball, and input changes needed to update PACKAGE to + "Return the version, tarball, and SOURCE, to update PACKAGE to SOURCE, an ." (match source - (($ _ version urls signature-urls changes) + (($ _ version urls signature-urls) (let*-values (((archive-type) (match (and=> (package-source package) origin-uri) ((? string? uri) @@ -371,7 +371,7 @@ SOURCE, an ." (or signature-urls (circular-list #f))))) (let ((tarball (download-tarball store url signature-url #:key-download key-download))) - (values version tarball changes)))))) + (values version tarball source)))))) (define %method-updates ;; Mapping of origin methods to source update procedures. -- cgit v1.2.3 From 42314ffa072f31cc1cb44df38b1f8fcca19d9d3c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 27 Mar 2019 14:56:23 +0100 Subject: refresh: Update the source code URL. Reported by Tobias Geerinckx-Rice in . * guix/upstream.scm (update-package-source): Take 'source' instead of 'version' as the second argument. [update-expression]: Change to take 'replacements', a list of replacement pairs. Compute OLD-URL and NEW-URL and replace the dirname of the OLD-URL with that of NEW-URL. * guix/scripts/refresh.scm (update-package): Adjust call to 'update-package-source' accordingly. --- guix/scripts/refresh.scm | 2 +- guix/upstream.scm | 62 ++++++++++++++++++++++++++++++++---------------- 2 files changed, 43 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 6d77e2642b..dd7026a6a4 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -333,7 +333,7 @@ warn about packages that have no matching updater." (upstream-source-input-changes source)) (let ((hash (call-with-input-file tarball port-sha256))) - (update-package-source package version hash))) + (update-package-source package source hash))) (warning (G_ "~a: version ~a could not be \ downloaded and authenticated; not updating~%") (package-name package) version)))) diff --git a/guix/upstream.scm b/guix/upstream.scm index 2c70b3422d..1326b3db95 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -39,6 +39,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:export (upstream-source @@ -404,36 +405,57 @@ this method: ~s") (#f (values #f #f #f)))) -(define (update-package-source package version hash) - "Modify the source file that defines PACKAGE to refer to VERSION, -whose tarball has SHA256 HASH (a bytevector). Return the new version string -if an update was made, and #f otherwise." - (define (update-expression expr old-version version old-hash hash) - ;; Update package expression EXPR, replacing occurrences OLD-VERSION by - ;; VERSION and occurrences of OLD-HASH by HASH (base32 representation - ;; thereof). - (let ((old-hash (bytevector->nix-base32-string old-hash)) - (hash (bytevector->nix-base32-string hash))) - (string-replace-substring - (string-replace-substring expr old-hash hash) - old-version version))) +(define* (update-package-source package source hash) + "Modify the source file that defines PACKAGE to refer to SOURCE, an + whose tarball has SHA256 HASH (a bytevector). Return the +new version string if an update was made, and #f otherwise." + (define (update-expression expr replacements) + ;; Apply REPLACEMENTS to package expression EXPR, a string. REPLACEMENTS + ;; must be a list of replacement pairs, either bytevectors or strings. + (fold (lambda (replacement str) + (match replacement + (((? bytevector? old-bv) . (? bytevector? new-bv)) + (string-replace-substring + str + (bytevector->nix-base32-string old-bv) + (bytevector->nix-base32-string new-bv))) + ((old . new) + (string-replace-substring str old new)))) + expr + replacements)) (let ((name (package-name package)) + (version (upstream-source-version source)) (version-loc (package-field-location package 'version))) (if version-loc (let* ((loc (package-location package)) (old-version (package-version package)) (old-hash (origin-sha256 (package-source package))) + (old-url (match (origin-uri (package-source package)) + ((? string? url) url) + (_ #f))) + (new-url (match (upstream-source-urls source) + ((first _ ...) first))) (file (and=> (location-file loc) (cut search-path %load-path <>)))) (if file - (and (edit-expression - ;; Be sure to use absolute filename. - (assq-set! (location->source-properties loc) - 'filename file) - (cut update-expression <> - old-version version old-hash hash)) - version) + ;; Be sure to use absolute filename. Replace the URL directory + ;; when OLD-URL is available; this is useful notably for + ;; mirror://cpan/ URLs where the directory may change as a + ;; function of the person who uploads the package. Note that + ;; package definitions usually concatenate fragments of the URL, + ;; which is why we only attempt to replace a subset of the URL. + (let ((properties (assq-set! (location->source-properties loc) + 'filename file)) + (replacements `((,old-version . ,version) + (,old-hash . ,hash) + ,@(if (and old-url new-url) + `((,(dirname old-url) . + ,(dirname new-url))) + '())))) + (and (edit-expression properties + (cut update-expression <> replacements)) + version)) (begin (warning (G_ "~a: could not locate source file") (location-file loc)) -- cgit v1.2.3 From 0244952c11c0409597fce5c39dfbcafdfd2ea651 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Thu, 28 Mar 2019 19:17:34 +0200 Subject: build-system/ruby: Use invoke. * guix/build/ruby-build-system.scm (install): Use invoke. --- guix/build/ruby-build-system.scm | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index ba0de1259e..49400b204d 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -143,14 +143,13 @@ GEM-FLAGS are passed to the 'gem' invokation, if present." (gem-dir (string-append vendor-dir "/gems/" gem-name))) (setenv "GEM_VENDOR" vendor-dir) - (or (zero? - (apply system* "gem" "install" gem-file - "--verbose" - "--local" "--ignore-dependencies" "--vendor" - ;; Executables should go into /bin, not - ;; /lib/ruby/gems. - "--bindir" (string-append out "/bin") - gem-flags)) + (or (apply invoke "gem" "install" gem-file + "--verbose" + "--local" "--ignore-dependencies" "--vendor" + ;; Executables should go into /bin, not + ;; /lib/ruby/gems. + "--bindir" (string-append out "/bin") + gem-flags) (begin (let ((failed-output-dir (string-append (getcwd) "/out"))) (mkdir failed-output-dir) -- cgit v1.2.3 From 7c86fdda7ceed11377b0e17b47c91598be59be52 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Thu, 28 Mar 2019 20:18:02 +0200 Subject: Revert "build-system/ruby: Use invoke." This reverts commit 0244952c11c0409597fce5c39dfbcafdfd2ea651. We prefer 'invoke', but the custom error handling works better with the code as-is. --- guix/build/ruby-build-system.scm | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index 49400b204d..63c94765f7 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -143,13 +143,16 @@ GEM-FLAGS are passed to the 'gem' invokation, if present." (gem-dir (string-append vendor-dir "/gems/" gem-name))) (setenv "GEM_VENDOR" vendor-dir) - (or (apply invoke "gem" "install" gem-file - "--verbose" - "--local" "--ignore-dependencies" "--vendor" - ;; Executables should go into /bin, not - ;; /lib/ruby/gems. - "--bindir" (string-append out "/bin") - gem-flags) + (or (zero? + ;; 'zero? system*' allows the custom error handling to function as + ;; expected, while 'invoke' raises its own exception. + (apply system* "gem" "install" gem-file + "--verbose" + "--local" "--ignore-dependencies" "--vendor" + ;; Executables should go into /bin, not + ;; /lib/ruby/gems. + "--bindir" (string-append out "/bin") + gem-flags)) (begin (let ((failed-output-dir (string-append (getcwd) "/out"))) (mkdir failed-output-dir) -- cgit v1.2.3 From 9f4169f6c8014206ea389e1ded88622fa6cfbe4a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 28 Mar 2019 15:55:47 +0100 Subject: pull: Factorize pretty-printing for new/upgraded package lists. * guix/scripts/pull.scm (display-new/upgraded-packages)[pretty]: New procedure. Use it. --- guix/scripts/pull.scm | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 730b6a0bf2..e06ec2f291 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -382,6 +382,11 @@ of packages upgraded in ALIST2." "Given the two package name/version alists ALIST1 and ALIST2, display the list of new and upgraded packages going from ALIST1 to ALIST2. When ALIST1 and ALIST2 differ, display HEADING upfront." + (define (pretty str column) + (indented-string (fill-paragraph str (- (%text-width) 4) + column) + 4)) + (let-values (((new upgraded) (new/upgraded-packages alist1 alist2))) (unless (and (null? new) (null? upgraded)) (display heading)) @@ -392,21 +397,17 @@ and ALIST2 differ, display HEADING upfront." (format #t (N_ " ~h new package: ~a~%" " ~h new packages: ~a~%" count) count - (indented-string - (fill-paragraph (string-join (sort (map first new) string Date: Thu, 28 Mar 2019 16:17:11 +0100 Subject: pull: Truncate the list of packages displayed on completion. Previously, if you'd run 'guix pull' after a couple of weeks, it would fill your screen with package names, which is unhelpful. * guix/scripts/pull.scm (ellipsis): New procedure. (display-new/upgraded-packages): Add #:concise?. [list->enumeration]: New procedure. Use it instead of 'string-join'. (display-profile-news): Pass #:concise? #t. --- guix/scripts/pull.scm | 27 ++++++++++++++++++++++----- 1 file changed, 22 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index e06ec2f291..2aaf1cc44a 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -181,6 +181,7 @@ Download and deploy the latest version of Guix.\n")) (new (profile-package-alist (generation-file-name profile current)))) (display-new/upgraded-packages old new + #:concise? #t #:heading (G_ "New in this revision:\n")))) (_ #t))) @@ -377,16 +378,33 @@ of packages upgraded in ALIST2." alist2))) (values new upgraded))) +(define* (ellipsis #:optional (port (current-output-port))) + "Return HORIZONTAL ELLIPSIS three dots if PORT's encoding cannot represent +it." + (match (port-encoding port) + ("UTF-8" "…") + (_ "..."))) + (define* (display-new/upgraded-packages alist1 alist2 - #:key (heading "")) + #:key (heading "") concise?) "Given the two package name/version alists ALIST1 and ALIST2, display the list of new and upgraded packages going from ALIST1 to ALIST2. When ALIST1 -and ALIST2 differ, display HEADING upfront." +and ALIST2 differ, display HEADING upfront. When CONCISE? is true, do not +display long package lists that would fill the user's screen." (define (pretty str column) (indented-string (fill-paragraph str (- (%text-width) 4) column) 4)) + (define list->enumeration + (if concise? + (lambda* (lst #:optional (max 12)) + (if (> (length lst) max) + (string-append (string-join (take lst max) ", ") + ", " (ellipsis)) + (string-join lst ", "))) + (cut string-join <> ", "))) + (let-values (((new upgraded) (new/upgraded-packages alist1 alist2))) (unless (and (null? new) (null? upgraded)) (display heading)) @@ -397,8 +415,7 @@ and ALIST2 differ, display HEADING upfront." (format #t (N_ " ~h new package: ~a~%" " ~h new packages: ~a~%" count) count - (pretty (string-join (sort (map first new) stringenumeration (sort (map first new) stringenumeration (sort upgraded string Date: Fri, 29 Mar 2019 22:40:55 +0100 Subject: records: Support custom 'this' identifiers. This lets record users choose an identifier other than 'this-record'. * guix/records.scm (make-syntactic-constructor): Add #:this-identifier. [wrap-field-value]: Honor it. (define-record-type*): Add form with extra THIS-IDENTIFIER and honor it. * tests/records.scm ("define-record-type* & thunked & inherit & custom this"): New test. --- guix/records.scm | 32 +++++++++++++++++++++++++++++--- tests/records.scm | 18 ++++++++++++++++++ 2 files changed, 47 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/records.scm b/guix/records.scm index 244b124098..99507dc384 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -118,6 +118,7 @@ of TYPE matches the expansion-time ABI." ((_ type name ctor (expected ...) #:abi-cookie abi-cookie #:thunked thunked + #:this-identifier this-identifier #:delayed delayed #:innate innate #:defaults defaults) @@ -162,7 +163,7 @@ of TYPE matches the expansion-time ABI." (define (wrap-field-value f value) (cond ((thunked-field? f) #`(lambda (x) - (syntax-parameterize ((this-record + (syntax-parameterize ((#,this-identifier (lambda (s) (syntax-case s () (id @@ -254,6 +255,7 @@ may look like this: (define-record-type* thing make-thing thing? + this-thing (name thing-name (default \"chbouib\")) (port thing-port (default (current-output-port)) (thunked)) @@ -273,7 +275,8 @@ default value specified in the 'define-record-type*' form is used: The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will actually compute the field's value in the current dynamic extent, which is -useful when referring to fluids in a field's value. +useful when referring to fluids in a field's value. Furthermore, that thunk +can access the record it belongs to via the 'this-thing' identifier. A field can also be marked as \"delayed\" instead of \"thunked\", in which case its value is effectively wrapped in a (delay …) form. @@ -352,7 +355,9 @@ inherited." (syntax-case s () ((_ type syntactic-ctor ctor pred + this-identifier (field get properties ...) ...) + (identifier? #'this-identifier) (let* ((field-spec #'((field get properties ...) ...)) (thunked (filter-map thunked-field? field-spec)) (delayed (filter-map delayed-field? field-spec)) @@ -381,15 +386,36 @@ inherited." field-spec* ...) (define #,(current-abi-identifier #'type) #,cookie) + + #,@(if (free-identifier=? #'this-identifier #'this-record) + #'() + #'((define-syntax-parameter this-identifier + (lambda (s) + "Return the record being defined. This macro may +only be used in the context of the definition of a thunked field." + (syntax-case s () + (id + (identifier? #'id) + (syntax-violation 'this-identifier + "cannot be used outside \ +of a record instantiation" + #'id))))))) thunked-field-accessor ... delayed-field-accessor ... (make-syntactic-constructor type syntactic-ctor ctor (field ...) #:abi-cookie #,cookie #:thunked #,thunked + #:this-identifier #'this-identifier #:delayed #,delayed #:innate #,innate - #:defaults #,defaults)))))))) + #:defaults #,defaults))))) + ((_ type syntactic-ctor ctor pred + (field get properties ...) ...) + ;; When no 'this' identifier was specified, use 'this-record'. + #'(define-record-type* type syntactic-ctor ctor pred + this-record + (field get properties ...) ...))))) (define* (alist->record alist make keys #:optional (multiple-value-keys '())) diff --git a/tests/records.scm b/tests/records.scm index 45614093a0..16b7a9c35e 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -210,6 +210,24 @@ (= 40 (foo-bar z)) (= -2 (foo-baz z)))))) +(test-assert "define-record-type* & thunked & inherit & custom this" + (let () + (define-record-type* foo make-foo + foo? this-foo + (thing foo-thing (thunked))) + (define-record-type* bar make-bar + bar? this-bar + (baz bar-baz (thunked))) + + ;; Nest records and test the two self references. + (let* ((x (foo (thing (bar (baz (list this-bar this-foo)))))) + (y (foo-thing x))) + (match (bar-baz y) + ((first second) + (and (eq? second x) + (bar? first) + (eq? first y))))))) + (test-assert "define-record-type* & delayed" (begin (define-record-type* foo make-foo -- cgit v1.2.3 From adb6462c4ce51fcdc94d3608ad6efb4adf716018 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 29 Mar 2019 22:49:00 +0100 Subject: packages: Define 'this-package' and 'this-origin'. * guix/packages.scm (): Choose 'this-origin' as the 'this' identifier. (): Choose 'this-package'. * gnu/packages/gnucash.scm (gnucash)[arguments]: Use 'this-package' instead of 'this-record'. * gnu/packages/version-control.scm (git)[arguments]: Likewise. --- gnu/packages/gnucash.scm | 5 ++--- gnu/packages/version-control.scm | 5 ++--- guix/packages.scm | 4 ++++ 3 files changed, 8 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/gnu/packages/gnucash.scm b/gnu/packages/gnucash.scm index 342df650aa..5b4da97e5d 100644 --- a/gnu/packages/gnucash.scm +++ b/gnu/packages/gnucash.scm @@ -27,7 +27,6 @@ #:use-module (guix download) #:use-module (guix build-system gnu) #:use-module (guix build-system cmake) - #:use-module ((guix records) #:select (this-record)) #:use-module (gnu packages) #:use-module (gnu packages autotools) #:use-module (gnu packages base) @@ -165,14 +164,14 @@ ,@(transitive-input-references 'inputs (map (lambda (l) - (assoc l (package-inputs this-record))) + (assoc l (package-inputs this-package))) '("perl-finance-quote" "perl-date-manip")))) (list ,@(transitive-input-references 'inputs (map (lambda (l) - (assoc l (package-inputs this-record))) + (assoc l (package-inputs this-package))) '("perl-finance-quote"))))))))) '("gnucash" "gnc-fq-check" diff --git a/gnu/packages/version-control.scm b/gnu/packages/version-control.scm index fe9b64ba5c..667b2881b1 100644 --- a/gnu/packages/version-control.scm +++ b/gnu/packages/version-control.scm @@ -51,7 +51,6 @@ #:use-module (guix build-system haskell) #:use-module (guix build-system python) #:use-module (guix build-system trivial) - #:use-module ((guix records) #:select (this-record)) #:use-module (gnu packages apr) #:use-module (gnu packages autotools) #:use-module (gnu packages documentation) @@ -409,7 +408,7 @@ as well as the classic centralized workflow.") ,@(transitive-input-references 'inputs (map (lambda (l) - (assoc l (package-inputs this-record))) + (assoc l (package-inputs this-package))) '("perl-authen-sasl" "perl-net-smtp-ssl" "perl-io-socket-ssl"))))))) @@ -422,7 +421,7 @@ as well as the classic centralized workflow.") ,@(transitive-input-references 'inputs (map (lambda (l) - (assoc l (package-inputs this-record))) + (assoc l (package-inputs this-package))) '("perl-cgi"))))))) ;; Tell 'git-submodule' where Perl is. diff --git a/guix/packages.scm b/guix/packages.scm index 9d83de3d48..b402637508 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -48,6 +48,7 @@ search-path-specification) ;for convenience #:export (origin origin? + this-origin origin-uri origin-method origin-sha256 @@ -63,6 +64,7 @@ package package? + this-package package-name package-upstream-name package-version @@ -156,6 +158,7 @@ (define-record-type* origin make-origin origin? + this-origin (uri origin-uri) ; string (method origin-method) ; procedure (sha256 origin-sha256) ; bytevector @@ -247,6 +250,7 @@ name of its URI." (define-record-type* package make-package package? + this-package (name package-name) ; string (version package-version) ; string (source package-source) ; instance -- cgit v1.2.3 From a7646bc5e17a829d23519d0b199a576fb1edbd04 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 30 Mar 2019 14:59:26 +0100 Subject: packages: Remove 'self-native-input?' field. This field has become unnecessary with the addition of 'this-package'. * guix/packages.scm ()[self-native-input?]: Remove. (package->bag): Adjust accordingly. * doc/guix.texi (package Reference): Remove 'self-native-input?'. --- doc/guix.texi | 4 ---- guix/packages.scm | 11 ++--------- 2 files changed, 2 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index d6dda9904c..527f9bcd10 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5361,10 +5361,6 @@ more. To ensure that libraries written in those languages can find library code they depend on at run time, run-time dependencies must be listed in @code{propagated-inputs} rather than @code{inputs}. -@item @code{self-native-input?} (default: @code{#f}) -This is a Boolean field telling whether the package should use itself as -a native input when cross-compiling. - @item @code{outputs} (default: @code{'("out")}) The list of output names of the package. @xref{Packages with Multiple Outputs}, for typical uses of additional outputs. diff --git a/guix/packages.scm b/guix/packages.scm index b402637508..1d3d99ba65 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -264,9 +264,6 @@ name of its URI." (default '()) (thunked)) (native-inputs package-native-inputs ; native input packages/derivations (default '()) (thunked)) - (self-native-input? package-self-native-input? ; whether to use itself as - ; a native input when cross- - (default #f)) ; compiling (outputs package-outputs ; list of strings (default '("out"))) @@ -1032,7 +1029,7 @@ and return it." ((and self ($ name version source build-system args inputs propagated-inputs native-inputs - self-native-input? outputs)) + outputs)) ;; Even though we prefer to use "@" to separate the package ;; name from the package version in various user-facing parts ;; of Guix, checkStoreName (in nix/libstore/store-api.cc) @@ -1044,11 +1041,7 @@ and return it." #:inputs (append (inputs self) (propagated-inputs self)) #:outputs outputs - #:native-inputs `(,@(if (and target - self-native-input?) - `(("self" ,self)) - '()) - ,@(native-inputs self)) + #:native-inputs (native-inputs self) #:arguments (args self)) (raise (if target (condition -- cgit v1.2.3 From 154f1f0937754fafac0c6288dd458b66b332e6bb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 30 Mar 2019 15:00:41 +0100 Subject: packages: Remove 'maintainers' field. This field was never used and doesn't match the way we collectively maintain packages. * guix/packages.scm ()[maintainers]: Remove. --- guix/packages.scm | 2 -- 1 file changed, 2 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 1d3d99ba65..c2981dda8b 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -84,7 +84,6 @@ package-license package-home-page package-supported-systems - package-maintainers package-properties package-location hidden-package @@ -286,7 +285,6 @@ name of its URI." (home-page package-home-page) (supported-systems package-supported-systems ; list of strings (default %supported-systems)) - (maintainers package-maintainers (default '())) (properties package-properties (default '())) ; alist for anything else -- cgit v1.2.3 From 1ccc0f807d3f22fa9ade1c607c112e04df833a72 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 2 Apr 2019 10:57:24 +0200 Subject: environment: '-C' creates namespaces where the user is not root. * guix/scripts/environment.scm (launch-environment/container): Add UID and GID. Use them in PASSWD and GROUPS. Pass them as #:guest-uid and #:guest-gid to 'call-with-container'. * tests/guix-environment-container.sh: Test the inner UID. In '--user' test, replace hard-coded 0 with 1000. * doc/guix.texi (Invoking guix environment): Adjust accordingly. --- doc/guix.texi | 13 ++++++++----- guix/scripts/environment.scm | 8 ++++++-- tests/guix-environment-container.sh | 15 ++++++++++++++- 3 files changed, 28 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 616970b505..616c2ef305 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4557,9 +4557,11 @@ Run @var{command} within an isolated container. The current working directory outside the container is mapped inside the container. Additionally, unless overridden with @code{--user}, a dummy home directory is created that matches the current user's home directory, and -@file{/etc/passwd} is configured accordingly. The spawned process runs -as the current user outside the container, but has root privileges in -the context of the container. +@file{/etc/passwd} is configured accordingly. + +The spawned process runs as the current user outside the container. Inside +the container, it has the same UID and GID as the current user, unless +@option{--user} is passed (see below.) @item --network @itemx -N @@ -4587,8 +4589,9 @@ the environment. @itemx -u @var{user} For containers, use the username @var{user} in place of the current user. The generated @file{/etc/passwd} entry within the container will -contain the name @var{user}; the home directory will be -@file{/home/USER}; and no user GECOS data will be copied. @var{user} +contain the name @var{user}, the home directory will be +@file{/home/@var{user}}, and no user GECOS data will be copied. Furthermore, +the UID and GID inside the container are 1000. @var{user} need not exist on the system. Additionally, any shared or exposed path (see @code{--share} and diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index c27edc7982..2d1ba4c938 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -459,17 +459,19 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (return (let* ((cwd (getcwd)) (home (getenv "HOME")) + (uid (if user 1000 (getuid))) + (gid (if user 1000 (getgid))) (passwd (let ((pwd (getpwuid (getuid)))) (password-entry (name (or user (passwd:name pwd))) (real-name (if user "" (passwd:gecos pwd))) - (uid 0) (gid 0) (shell bash) + (uid uid) (gid gid) (shell bash) (directory (if user (string-append "/home/" user) (passwd:dir pwd)))))) - (groups (list (group-entry (name "users") (gid 0)) + (groups (list (group-entry (name "users") (gid gid)) (group-entry (gid 65534) ;the overflow GID (name "overflow")))) (home-dir (password-entry-directory passwd)) @@ -541,6 +543,8 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from ;; A container's environment is already purified, so no need to ;; request it be purified again. (launch-environment command profile manifest #:pure? #f))) + #:guest-uid uid + #:guest-gid gid #:namespaces (if network? (delq 'net %namespaces) ; share host network %namespaces))))))) diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh index f2221af95b..78507f76c0 100644 --- a/tests/guix-environment-container.sh +++ b/tests/guix-environment-container.sh @@ -44,6 +44,19 @@ else test $? = 42 fi +# By default, the UID inside the container should be the same as outside. +uid="`id -u`" +inner_uid="`guix environment -C --ad-hoc --bootstrap guile-bootstrap \ + -- guile -c '(display (getuid))'`" +test $inner_uid = $uid + +# When '--user' is passed, the UID should be 1000. (Note: Use a separate HOME +# so that we don't run into problems when the test directory is under /home.) +export tmpdir +inner_uid="`HOME=$tmpdir guix environment -C --ad-hoc --bootstrap guile-bootstrap \ + --user=gnu-guix -- guile -c '(display (getuid))'`" +test $inner_uid = 1000 + if test "x$USER" = "x"; then USER="`id -un`"; fi # Check whether /etc/passwd and /etc/group are valid. @@ -123,7 +136,7 @@ rm $tmpdir/mounts # Test that user can be mocked. usertest='(exit (and (string=? (getenv "HOME") "/home/foognu") - (string=? (passwd:name (getpwuid 0)) "foognu") + (string=? (passwd:name (getpwuid 1000)) "foognu") (file-exists? "/home/foognu/umock")))' touch "$tmpdir/umock" HOME="$tmpdir" guix environment --bootstrap --container --user=foognu \ -- cgit v1.2.3 From 5a6e04c53cee8d35feaa40755fa362dc1bb672de Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 3 Apr 2019 18:20:36 +0200 Subject: self: Ship all the (gnu bootloader …) modules. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/self.scm (compiled-guix)[*system-modules*]: Explicitly add all of gnu/bootloader/*. --- guix/self.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index ccff9be5b3..7ba2764eb9 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -627,6 +627,7 @@ Info manual." (scheme-node "guix-system" `((gnu system) (gnu services) + ,@(scheme-modules* source "gnu/bootloader") ,@(scheme-modules* source "gnu/system") ,@(scheme-modules* source "gnu/services")) (list *core-package-modules* *package-modules* -- cgit v1.2.3 From a31174e896047e6a0f42b69db331fdeebb3cc995 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 4 Apr 2019 17:18:06 +0200 Subject: gexp: 'compiled-modules' loads modules before compiling them. This works around in the context of modules specified with 'with-imported-modules'. * guix/gexp.scm (gexp->derivation): Add #:pre-load-modules? parameter and pass it to 'compiled-modules'. (compiled-modules): Add #:pre-load-modules? parameter and honor it. * guix/packages.scm (patch-and-repack): Pass #:pre-load-modules? to 'gexp->derivation'. --- guix/gexp.scm | 47 +++++++++++++++++++++++++++++++++++++++++++++-- guix/packages.scm | 3 +++ 2 files changed, 48 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 5b5b064b59..4f2adba90a 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -634,6 +634,11 @@ names and file names suitable for the #:allowed-references argument to local-build? (substitutable? #t) (properties '()) + ;; TODO: This parameter is transitional; it's here + ;; to avoid a full rebuild. Remove it on the next + ;; rebuild cycle. + (pre-load-modules? #t) + deprecation-warnings (script-name (string-append name "-builder"))) "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a @@ -738,6 +743,8 @@ The other arguments are as for 'derivation'." #:module-path module-path #:extensions extensions #:guile guile-for-build + #:pre-load-modules? + pre-load-modules? #:deprecation-warnings deprecation-warnings) (return #f))) @@ -1213,7 +1220,11 @@ last one is created from the given object." (guile (%guile-for-build)) (module-path %load-path) (extensions '()) - (deprecation-warnings #f)) + (deprecation-warnings #f) + + ;; TODO: This flag is here to prevent a full + ;; rebuild. Remove it on the next rebuild cycle. + (pre-load-modules? #t)) "Return a derivation that builds a tree containing the `.go' files corresponding to MODULES. All the MODULES are built in a context where they can refer to each other." @@ -1246,7 +1257,12 @@ they can refer to each other." (let* ((base (basename entry ".scm")) (output (string-append output "/" base ".go"))) (format #t "[~2@a/~2@a] Compiling '~a'...~%" - (+ 1 processed) (ungexp total) entry) + (+ 1 processed + (ungexp-splicing (if pre-load-modules? + (gexp ((ungexp total))) + (gexp ())))) + (ungexp (* total (if pre-load-modules? 2 1))) + entry) (compile-file entry #:output-file output #:opts %auto-compilation-options) @@ -1293,6 +1309,33 @@ they can refer to each other." (mkdir (ungexp output)) (chdir (ungexp modules)) + + (ungexp-splicing + (if pre-load-modules? + (gexp ((define* (load-from-directory directory + #:optional (loaded 0)) + "Load all the source files found in DIRECTORY." + ;; XXX: This works around . + (let ((entries (map (cut string-append directory "/" <>) + (scandir directory regular?)))) + (fold (lambda (file loaded) + (if (file-is-directory? file) + (load-from-directory file loaded) + (begin + (format #t "[~2@a/~2@a] Loading '~a'...~%" + (+ 1 loaded) + (ungexp (* 2 total)) + file) + (save-module-excursion + (lambda () + (primitive-load file))) + (+ 1 loaded)))) + loaded + entries))) + + (load-from-directory "."))) + (gexp ()))) + (process-directory "." (ungexp output) 0)))) ;; TODO: Pass MODULES as an environment variable. diff --git a/guix/packages.scm b/guix/packages.scm index c2981dda8b..c94a651f27 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -642,6 +642,9 @@ specifies modules in scope when evaluating SNIPPET." (let ((name (tarxz-name original-file-name))) (gexp->derivation name build + ;; TODO: Remove this on the next rebuild cycle. + #:pre-load-modules? #f + #:graft? #f #:system system #:deprecation-warnings #t ;to avoid a rebuild -- cgit v1.2.3 From c1ef50ac79ff56bebe81a173a858d83a1bee6a36 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 4 Apr 2019 17:28:00 +0200 Subject: gexp: Remove workarounds for . * gnu/services/base.scm (hydra-key-authorization)[aaa]: Remove. [default-acl]: Don't import it. * guix/scripts/pack.scm (store-database)[build]: Don't import (gnu build install). --- gnu/services/base.scm | 10 ---------- guix/scripts/pack.scm | 6 +----- 2 files changed, 1 insertion(+), 15 deletions(-) (limited to 'guix') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 04b123b833..246932e5c8 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -1515,19 +1515,9 @@ GID." (define (hydra-key-authorization keys guix) "Return a gexp with code to register KEYS, a list of files containing 'guix archive' public keys, with GUIX." - (define aaa - ;; XXX: Terrible hack to work around : this - ;; forces (guix config) and (guix utils) to be loaded upfront, so that - ;; their run-time symbols are defined. - (scheme-file "aaa.scm" - #~(define-module (guix aaa) - #:use-module (guix config) - #:use-module (guix memoization)))) - (define default-acl (with-extensions (list guile-gcrypt) (with-imported-modules `(((guix config) => ,(make-config.scm)) - ((guix aaa) => ,aaa) ,@(source-module-closure '((guix pki)) #:select? not-config?)) (computed-file "acl" diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index e5502ef9ca..d2ef68d153 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -126,13 +126,9 @@ dependencies are registered." (define build (with-extensions gcrypt-sqlite3&co - ;; XXX: Adding (gnu build install) just to work around - ;; : that way, (guix build store-copy) is - ;; copied last and the 'store-info-XXX' macros are correctly expanded. (with-imported-modules (source-module-closure '((guix build store-copy) - (guix store database) - (gnu build install))) + (guix store database))) #~(begin (use-modules (guix store database) (guix build store-copy) -- cgit v1.2.3 From 985730c1afac6b5077df9ca8a871db9750ac3a9d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 4 Apr 2019 17:32:37 +0200 Subject: scripts: More commands default to verbosity level 1. * guix/scripts/environment.scm (%default-options): Change 'verbosity' to 1. * guix/scripts/pack.scm (%default-options): Likewise. * guix/scripts/system.scm (guix-system): Likewise, except for the 'build' command. --- guix/scripts/environment.scm | 2 +- guix/scripts/pack.scm | 2 +- guix/scripts/system.scm | 3 +-- 3 files changed, 3 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 2d1ba4c938..99c351ae43 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -192,7 +192,7 @@ COMMAND or an interactive shell in that environment.\n")) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) (debug . 0) - (verbosity . 2))) + (verbosity . 1))) (define (tag-package-arg opts arg) "Return a two-element list with the form (TAG ARG) that tags ARG with either diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index d2ef68d153..b1d1e87c57 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -629,7 +629,7 @@ please email '~a'~%") (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) (debug . 0) - (verbosity . 2) + (verbosity . 1) (symlinks . ()) (compressor . ,(first %compressors)))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 97508f4bd6..78aa6cf644 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1299,8 +1299,7 @@ argument list and OPTS is the option alist." (command (assoc-ref opts 'action))) (parameterize ((%graft? (assoc-ref opts 'graft?))) (with-status-verbosity (or (assoc-ref opts 'verbosity) - (if (memq command '(init reconfigure)) - 1 2)) + (if (eq? command 'build) 2 1)) (process-command command args opts)))))) ;;; Local Variables: -- cgit v1.2.3 From cd0a9c91b234fae61cd3542ac13fbb1d208873be Mon Sep 17 00:00:00 2001 From: Katherine Cox-Buday Date: Fri, 29 Mar 2019 12:21:35 -0500 Subject: licenses: Add Lisp Lesser General Public License. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/licenses.scm (llgpl): New variable. Signed-off-by: 宋文武 --- guix/licenses.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index 676e71acdb..952c3bfd1a 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -65,7 +65,7 @@ imlib2 ipa knuth - lgpl2.0 lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3 lgpl3+ + lgpl2.0 lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3 lgpl3+ llgpl lppl lppl1.0+ lppl1.1+ lppl1.2 lppl1.2+ lppl1.3 lppl1.3+ lppl1.3a lppl1.3a+ @@ -417,6 +417,11 @@ at URI, which may be a file:// URI pointing the package's tree." "https://www.gnu.org/licenses/lgpl.html" "https://www.gnu.org/licenses/license-list#LGPLv3")) +(define llgpl + (license "LLGPL" + "https://opensource.franz.com/preamble.html" + "Lisp Lesser General Public License")) + (define lppl (license "LPPL (any version)" "https://www.latex-project.org/lppl/lppl-1-0/" -- cgit v1.2.3 From 1199da08aa76f7bba57692b4b8e9272fd305e9f2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Apr 2019 14:52:56 +0200 Subject: size: Optimize dependency size computation. This reduces 'guix size' run time by ~4% here: items="$(guix build icecat inkscape emacs libreoffice)" guix size $items * guix/scripts/size.scm (store-profile): Define 'size-table' and use it to lookup the size of ITEM in 'dependency-size'. --- guix/scripts/size.scm | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index 25218a2945..f549ce05b8 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,6 +34,7 @@ #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:use-module (ice-9 format) + #:use-module (ice-9 vlist) #:export (profile? profile-file profile-self-size @@ -142,11 +143,20 @@ profile of ITEMS and their requisites." (lambda (size) (return (cons item size))))) refs))) + (define size-table + (fold (lambda (pair result) + (match pair + ((item . size) + (vhash-cons item size result)))) + vlist-null sizes)) + (define (dependency-size item) (mlet %store-monad ((deps (requisites* (list item)))) (foldm %store-monad (lambda (item total) - (return (+ (assoc-ref sizes item) total))) + (return (+ (match (vhash-assoc item size-table) + ((_ . size) size)) + total))) 0 (delete-duplicates (cons item deps))))) -- cgit v1.2.3 From b227457f6209695d8c612f9bbd60d76a1bfa766c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Apr 2019 10:24:51 +0200 Subject: licenses: Remove 'bsd-style'. This procedure had been deprecated since March 2015. * guix/licenses.scm (bsd-style): Remove. --- guix/licenses.scm | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index 952c3bfd1a..65d9c3da13 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2014, 2015, 2017 Ludovic Courtès +;;; Copyright © 2012, 2014, 2015, 2017, 2019 Ludovic Courtès ;;; Copyright © 2013, 2015 Andreas Enge ;;; Copyright © 2012, 2013 Nikita Karetnikov ;;; Copyright © 2015 Mark H Weaver @@ -38,7 +38,6 @@ boost1.0 bsd-2 bsd-3 bsd-4 non-copyleft - bsd-style ;deprecated! cc0 cc-by2.0 cc-by3.0 cc-by4.0 cc-by-sa2.0 cc-by-sa3.0 cc-by-sa4.0 @@ -170,12 +169,6 @@ at URI, which may be a file:// URI pointing the package's tree." "Check the URI for details. " comment))) -(define bsd-style - ;; This alias is kept for backward-compatibility. Do not use it for new - ;; packages: it is ambiguous, as rightfully explained at - ;; . - non-copyleft) - (define cc0 (license "CC0" "http://directory.fsf.org/wiki/License:CC0" -- cgit v1.2.3 From 1d3acde5087d50af6a4901fd7614f0940eb7b41d Mon Sep 17 00:00:00 2001 From: Ivan Petkov Date: Tue, 2 Apr 2019 03:02:51 -0700 Subject: build-system/cargo: refactor phases to successfully build * guix/build-system/cargo.scm (%cargo-build-system-modules): Add (json parser). (cargo-build): [vendor-dir]: Define flag and pass it to builder code. [cargo-test-flags]: Likewise. [skip-build?]: Likewise. * guix/build/cargo-build/system.scm (#:use-module): use (json parser). (package-name->crate-name): Delete it. (manifest-targets): Add it. (has-executable-target?): Add it. (configure): Add #:vendor-dir name and use it. Don't touch Cargo.toml. Don't symlink to duplicate inputs. Remove useless registry line from cargo config. Define RUSTFLAGS to lift lint restrictions. (build): Add #:skip-build? flag and use it. (check): Likewise. Add #:cargo-test-flags and pass it to cargo. (install): Factor source logic to install-source. Define #:skip-build? flag and use it. Only install if executable targets are present. (install-source): Copy entire crate directory not just src. [generate-checksums] pass dummy file for unused second argument. (%standard-phases): Add install-source phase. Signed-off-by: Chris Marusich --- guix/build-system/cargo.scm | 9 ++- guix/build/cargo-build-system.scm | 155 +++++++++++++++++++++----------------- 2 files changed, 95 insertions(+), 69 deletions(-) (limited to 'guix') diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index 7ff4e90f71..dc137421e9 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -59,13 +59,17 @@ to NAME and VERSION." (define %cargo-build-system-modules ;; Build-side modules imported by default. `((guix build cargo-build-system) + (json parser) ,@%cargo-utils-modules)) (define* (cargo-build store name inputs #:key (tests? #t) (test-target #f) + (vendor-dir "guix-vendor") (cargo-build-flags ''("--release")) + (cargo-test-flags ''("--release")) + (skip-build? #f) (phases '(@ (guix build cargo-build-system) %standard-phases)) (outputs '("out")) @@ -90,8 +94,11 @@ to NAME and VERSION." source)) #:system ,system #:test-target ,test-target + #:vendor-dir ,vendor-dir #:cargo-build-flags ,cargo-build-flags - #:tests? ,tests? + #:cargo-test-flags ,cargo-test-flags + #:skip-build? ,skip-build? + #:tests? ,(and tests? (not skip-build?)) #:phases ,phases #:outputs %outputs #:search-paths ',(map search-path-specification->sexp diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 20087fa6c4..b68a1f90d2 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven ;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2019 Ivan Petkov ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ #:use-module (ice-9 ftw) #:use-module (ice-9 format) #:use-module (ice-9 match) + #:use-module (json parser) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases @@ -37,81 +39,86 @@ ;; ;; Code: -;; FIXME: Needs to be parsed from url not package name. -(define (package-name->crate-name name) - "Return the crate name of NAME." - (match (string-split name #\-) - (("rust" rest ...) - (string-join rest "-")) - (_ #f))) - -(define* (configure #:key inputs #:allow-other-keys) - "Replace Cargo.toml [dependencies] section with guix inputs." - ;; Make sure Cargo.toml is writeable when the crate uses git-fetch. - (chmod "Cargo.toml" #o644) +(define (manifest-targets) + "Extract all targets from the Cargo.toml manifest" + (let* ((port (open-input-pipe "cargo read-manifest")) + (data (json->scm port)) + (targets (hash-ref data "targets" '()))) + (close-port port) + targets)) + +(define (has-executable-target?) + "Check if the current cargo project declares any binary targets." + (let* ((bin? (lambda (kind) (string=? kind "bin"))) + (get-kinds (lambda (dep) (hash-ref dep "kind"))) + (bin-dep? (lambda (dep) (find bin? (get-kinds dep))))) + (find bin-dep? (manifest-targets)))) + +(define* (configure #:key inputs + (vendor-dir "guix-vendor") + #:allow-other-keys) + "Vendor Cargo.toml dependencies as guix inputs." (chmod "." #o755) - (if (not (file-exists? "vendor")) - (if (not (file-exists? "Cargo.lock")) - (begin - (substitute* "Cargo.toml" - ((".*32-sys.*") " -") - ((".*winapi.*") " -") - ((".*core-foundation.*") " -")) - ;; Prepare one new directory with all the required dependencies. - ;; It's necessary to do this (instead of just using /gnu/store as the - ;; directory) because we want to hide the libraries in subdirectories - ;; share/rust-source/... instead of polluting the user's profile root. - (mkdir "vendor") - (for-each - (match-lambda - ((name . path) - (let ((crate (package-name->crate-name name))) - (when (and crate path) - (match (string-split (basename path) #\-) - ((_ ... version) - (symlink (string-append path "/share/rust-source") - (string-append "vendor/" (basename path))))))))) - inputs) - ;; Configure cargo to actually use this new directory. - (mkdir-p ".cargo") - (let ((port (open-file ".cargo/config" "w" #:encoding "utf-8"))) - (display " + ;; Prepare one new directory with all the required dependencies. + ;; It's necessary to do this (instead of just using /gnu/store as the + ;; directory) because we want to hide the libraries in subdirectories + ;; share/rust-source/... instead of polluting the user's profile root. + (mkdir-p vendor-dir) + (for-each + (match-lambda + ((name . path) + (let* ((rust-share (string-append path "/share/rust-source")) + (basepath (basename path)) + (link-dir (string-append vendor-dir "/" basepath))) + (and (file-exists? rust-share) + ;; Gracefully handle duplicate inputs + (not (file-exists? link-dir)) + (symlink rust-share link-dir))))) + inputs) + ;; Configure cargo to actually use this new directory. + (mkdir-p ".cargo") + (let ((port (open-file ".cargo/config" "w" #:encoding "utf-8"))) + (display " [source.crates-io] -registry = 'https://github.com/rust-lang/crates.io-index' replace-with = 'vendored-sources' [source.vendored-sources] directory = '" port) - (display (getcwd) port) - (display "/vendor" port) - (display "' + (display (string-append (getcwd) "/" vendor-dir) port) + (display "' " port) - (close-port port))))) - (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc")) + (close-port port)) - ;(setenv "CARGO_HOME" "/gnu/store") - ; (setenv "CMAKE_C_COMPILER" cc) + ;; Lift restriction on any lints: a crate author may have decided to opt + ;; into stricter lints (e.g. #![deny(warnings)]) during their own builds + ;; but we don't want any build failures that could be caused later by + ;; upgrading the compiler for example. + (setenv "RUSTFLAGS" "--cap-lints allow") + (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc")) #t) -(define* (build #:key (cargo-build-flags '("--release")) +(define* (build #:key + skip-build? + (cargo-build-flags '("--release")) #:allow-other-keys) "Build a given Cargo package." - (zero? (apply system* `("cargo" "build" ,@cargo-build-flags)))) + (or skip-build? + (zero? (apply system* `("cargo" "build" ,@cargo-build-flags))))) -(define* (check #:key tests? #:allow-other-keys) +(define* (check #:key + tests? + (cargo-test-flags '("--release")) + #:allow-other-keys) "Run tests for a given Cargo package." - (if (and tests? (file-exists? "Cargo.lock")) - (zero? (system* "cargo" "test")) + (if tests? + (zero? (apply system* `("cargo" "test" ,@cargo-test-flags))) #t)) (define (touch file-name) (call-with-output-file file-name (const #t))) -(define* (install #:key inputs outputs #:allow-other-keys) - "Install a given Cargo package." +(define* (install-source #:key inputs outputs #:allow-other-keys) + "Install the source for a given Cargo package." (let* ((out (assoc-ref outputs "out")) (src (assoc-ref inputs "source")) (rsrc (string-append (assoc-ref outputs "src") @@ -120,24 +127,36 @@ directory = '" port) ;; Rust doesn't have a stable ABI yet. Because of this ;; Cargo doesn't have a search path for binaries yet. ;; Until this changes we are working around this by - ;; distributing crates as source and replacing - ;; references in Cargo.toml with store paths. - (copy-recursively "src" (string-append rsrc "/src")) + ;; vendoring the crates' sources by symlinking them + ;; to store paths. + (copy-recursively "." rsrc) (touch (string-append rsrc "/.cargo-ok")) - (generate-checksums rsrc src) + (generate-checksums rsrc "/dev/null") (install-file "Cargo.toml" rsrc) - ;; When the package includes executables we install - ;; it using cargo install. This fails when the crate - ;; doesn't contain an executable. - (if (file-exists? "Cargo.lock") - (zero? (system* "cargo" "install" "--root" out)) - (begin - (mkdir out) - #t)))) + #t)) + +(define* (install #:key inputs outputs skip-build? #:allow-other-keys) + "Install a given Cargo package." + (let* ((out (assoc-ref outputs "out"))) + (mkdir-p out) + + ;; Make cargo reuse all the artifacts we just built instead + ;; of defaulting to making a new temp directory + (setenv "CARGO_TARGET_DIR" "./target") + ;; Force cargo to honor our .cargo/config definitions + ;; https://github.com/rust-lang/cargo/issues/6397 + (setenv "CARGO_HOME" ".") + + ;; Only install crates which include binary targets, + ;; otherwise cargo will raise an error. + (or skip-build? + (not (has-executable-target?)) + (zero? (system* "cargo" "install" "--path" "." "--root" out))))) (define %standard-phases (modify-phases gnu:%standard-phases (delete 'bootstrap) + (add-before 'configure 'install-source install-source) (replace 'configure configure) (replace 'build build) (replace 'check check) -- cgit v1.2.3 From 21b3c0ca8789c22b9b689faa01286b18f103b92e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Apr 2019 22:16:37 +0200 Subject: guix package: Use absolute file names in search path recommendations. Suggested by Chris Marusich. * guix/scripts/package.scm (absolutize): New procedure. (display-search-paths): Use it. --- guix/scripts/package.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index b0c6a7ced7..564236988e 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -278,11 +278,19 @@ path definition to be returned." (evaluate-search-paths search-paths profiles getenv)))) +(define (absolutize file) + "Return an absolute file name equivalent to FILE, but without resolving +symlinks like 'canonicalize-path' would do." + (if (string-prefix? "/" file) + file + (string-append (getcwd) "/" file))) + (define* (display-search-paths entries profiles #:key (kind 'exact)) "Display the search path environment variables that may need to be set for ENTRIES, a list of manifest entries, in the context of PROFILE." - (let* ((profiles (map user-friendly-profile profiles)) + (let* ((profiles (map (compose user-friendly-profile absolutize) + profiles)) (settings (search-path-environment-variables entries profiles #:kind kind))) (unless (null? settings) -- cgit v1.2.3 From 95207e70d561517c8db8992f61552004f8213b04 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Apr 2019 09:52:48 +0200 Subject: store: 'with-store' expands to a single procedure call. * guix/store.scm (call-with-store): New procedure. (with-store): Write in terms of 'call-with-store'. --- guix/store.scm | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 0a0a7c7c52..fdd04f349d 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -602,19 +602,23 @@ connection. Use with care." "Close the connection to SERVER." (close (store-connection-socket server))) -(define-syntax-rule (with-store store exp ...) - "Bind STORE to an open connection to the store and evaluate EXPs; -automatically close the store when the dynamic extent of EXP is left." +(define (call-with-store proc) + "Call PROC with an open store connection." (let ((store (open-connection))) (dynamic-wind (const #f) (lambda () (parameterize ((current-store-protocol-version (store-connection-version store))) - exp) ...) + (proc store))) (lambda () (false-if-exception (close-connection store)))))) +(define-syntax-rule (with-store store exp ...) + "Bind STORE to an open connection to the store and evaluate EXPs; +automatically close the store when the dynamic extent of EXP is left." + (call-with-store (lambda (store) exp ...))) + (define current-store-protocol-version ;; Protocol version of the store currently used. XXX: This is a hack to ;; communicate the protocol version to the build output port. It's a hack -- cgit v1.2.3 From 5d9f9ad63191646a22dc80624227aa413a4894f0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Apr 2019 22:39:26 +0200 Subject: Add (guix colors). * guix/colors.scm: New file. * Makefile.am (MODULES): Add it. * guix/ui.scm (color-table, color, colorize-string): Remove. * guix/status.scm (isatty?*, color-output? color-rules): Remove. --- Makefile.am | 1 + guix/colors.scm | 129 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ guix/status.scm | 44 +------------------ guix/ui.scm | 55 +----------------------- 4 files changed, 132 insertions(+), 97 deletions(-) create mode 100644 guix/colors.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index c331da7267..87682b4949 100644 --- a/Makefile.am +++ b/Makefile.am @@ -138,6 +138,7 @@ MODULES = \ guix/store.scm \ guix/cvs-download.scm \ guix/svn-download.scm \ + guix/colors.scm \ guix/i18n.scm \ guix/ui.scm \ guix/status.scm \ diff --git a/guix/colors.scm b/guix/colors.scm new file mode 100644 index 0000000000..fad0bd2ab9 --- /dev/null +++ b/guix/colors.scm @@ -0,0 +1,129 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Free Software Foundation, Inc. +;;; Copyright © 2018 Sahithi Yarlagadda +;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2017, 2018, 2019 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix colors) + #:use-module (guix memoization) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:export (colorize-string + color-rules + color-output? + isatty?*)) + +;;; Commentary: +;;; +;;; This module provides tools to produce colored output using ANSI escapes. +;;; +;;; Code: + +(define color-table + `((CLEAR . "0") + (RESET . "0") + (BOLD . "1") + (DARK . "2") + (UNDERLINE . "4") + (UNDERSCORE . "4") + (BLINK . "5") + (REVERSE . "6") + (CONCEALED . "8") + (BLACK . "30") + (RED . "31") + (GREEN . "32") + (YELLOW . "33") + (BLUE . "34") + (MAGENTA . "35") + (CYAN . "36") + (WHITE . "37") + (ON-BLACK . "40") + (ON-RED . "41") + (ON-GREEN . "42") + (ON-YELLOW . "43") + (ON-BLUE . "44") + (ON-MAGENTA . "45") + (ON-CYAN . "46") + (ON-WHITE . "47"))) + +(define (color . lst) + "Return a string containing the ANSI escape sequence for producing the +requested set of attributes in LST. Unknown attributes are ignored." + (let ((color-list + (remove not + (map (lambda (color) (assq-ref color-table color)) + lst)))) + (if (null? color-list) + "" + (string-append + (string #\esc #\[) + (string-join color-list ";" 'infix) + "m")))) + +(define (colorize-string str . color-list) + "Return a copy of STR colorized using ANSI escape sequences according to the +attributes STR. At the end of the returned string, the color attributes will +be reset such that subsequent output will not have any colors in effect." + (string-append + (apply color color-list) + str + (color 'RESET))) + +(define isatty?* + (mlambdaq (port) + "Return true if PORT is a tty. Memoize the result." + (isatty? port))) + +(define (color-output? port) + "Return true if we should write colored output to PORT." + (and (not (getenv "INSIDE_EMACS")) + (not (getenv "NO_COLOR")) + (isatty?* port))) + +(define-syntax color-rules + (syntax-rules () + "Return a procedure that colorizes the string it is passed according to +the given rules. Each rule has the form: + + (REGEXP COLOR1 COLOR2 ...) + +where COLOR1 specifies how to colorize the first submatch of REGEXP, and so +on." + ((_ (regexp colors ...) rest ...) + (let ((next (color-rules rest ...)) + (rx (make-regexp regexp))) + (lambda (str) + (if (string-index str #\nul) + str + (match (regexp-exec rx str) + (#f (next str)) + (m (let loop ((n 1) + (c '(colors ...)) + (result '())) + (match c + (() + (string-concatenate-reverse result)) + ((first . tail) + (loop (+ n 1) tail + (cons (colorize-string (match:substring m n) + first) + result))))))))))) + ((_) + (lambda (str) + str)))) diff --git a/guix/status.scm b/guix/status.scm index bddaa003db..7edb558ee7 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -20,7 +20,7 @@ (define-module (guix status) #:use-module (guix records) #:use-module (guix i18n) - #:use-module ((guix ui) #:select (colorize-string)) + #:use-module (guix colors) #:use-module (guix progress) #:autoload (guix build syscalls) (terminal-columns) #:use-module ((guix build download) @@ -339,10 +339,6 @@ build-log\" traces." (and (current-store-protocol-version) (>= (current-store-protocol-version) #x163))) -(define isatty?* - (mlambdaq (port) - (isatty? port))) - (define spin! (let ((steps (circular-list "\\" "|" "/" "-"))) (lambda (phase port) @@ -362,44 +358,6 @@ the current build phase." (format port (G_ "'~a' phase") phase)) (force-output port))))))) -(define (color-output? port) - "Return true if we should write colored output to PORT." - (and (not (getenv "INSIDE_EMACS")) - (not (getenv "NO_COLOR")) - (isatty?* port))) - -(define-syntax color-rules - (syntax-rules () - "Return a procedure that colorizes the string it is passed according to -the given rules. Each rule has the form: - - (REGEXP COLOR1 COLOR2 ...) - -where COLOR1 specifies how to colorize the first submatch of REGEXP, and so -on." - ((_ (regexp colors ...) rest ...) - (let ((next (color-rules rest ...)) - (rx (make-regexp regexp))) - (lambda (str) - (if (string-index str #\nul) - str - (match (regexp-exec rx str) - (#f (next str)) - (m (let loop ((n 1) - (c '(colors ...)) - (result '())) - (match c - (() - (string-concatenate-reverse result)) - ((first . tail) - (loop (+ n 1) tail - (cons (colorize-string (match:substring m n) - first) - result))))))))))) - ((_) - (lambda (str) - str)))) - (define colorize-log-line ;; Take a string and return a possibly colorized string according to the ;; rules below. diff --git a/guix/ui.scm b/guix/ui.scm index 0070301c47..c2807b711f 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -10,8 +10,6 @@ ;;; Copyright © 2016 Roel Janssen ;;; Copyright © 2016 Benz Schenk ;;; Copyright © 2018 Kyle Meyer -;;; Copyright © 2013, 2014 Free Software Foundation, Inc. -;;; Copyright © 2018 Sahithi Yarlagadda ;;; Copyright © 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. @@ -118,8 +116,7 @@ guix-warning-port warning info - guix-main - colorize-string)) + guix-main)) ;;; Commentary: ;;; @@ -1703,54 +1700,4 @@ and signal handling has already been set up." (initialize-guix) (apply run-guix args)) -(define color-table - `((CLEAR . "0") - (RESET . "0") - (BOLD . "1") - (DARK . "2") - (UNDERLINE . "4") - (UNDERSCORE . "4") - (BLINK . "5") - (REVERSE . "6") - (CONCEALED . "8") - (BLACK . "30") - (RED . "31") - (GREEN . "32") - (YELLOW . "33") - (BLUE . "34") - (MAGENTA . "35") - (CYAN . "36") - (WHITE . "37") - (ON-BLACK . "40") - (ON-RED . "41") - (ON-GREEN . "42") - (ON-YELLOW . "43") - (ON-BLUE . "44") - (ON-MAGENTA . "45") - (ON-CYAN . "46") - (ON-WHITE . "47"))) - -(define (color . lst) - "Return a string containing the ANSI escape sequence for producing the -requested set of attributes in LST. Unknown attributes are ignored." - (let ((color-list - (remove not - (map (lambda (color) (assq-ref color-table color)) - lst)))) - (if (null? color-list) - "" - (string-append - (string #\esc #\[) - (string-join color-list ";" 'infix) - "m")))) - -(define (colorize-string str . color-list) - "Return a copy of STR colorized using ANSI escape sequences according to the -attributes STR. At the end of the returned string, the color attributes will -be reset such that subsequent output will not have any colors in effect." - (string-append - (apply color color-list) - str - (color 'RESET))) - ;;; ui.scm ends here -- cgit v1.2.3 From 32813e8440ff15c9389b84b1d7450fe1d3d25bb2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Apr 2019 23:06:38 +0200 Subject: ui: Fix i18n for diagnostic messages. Until now, we'd pass 'gettext' the "augmented" format string, which 'gettext' would not find in message catalogs. Now we pass it FMT as is, which is what catalogs contain. * guix/ui.scm (define-diagnostic)[augmented-format-string]: Remove. Emit one 'format' call to print the prefix, and a second one to print the actual message. --- guix/ui.scm | 22 +++++++++------------- 1 file changed, 9 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index c2807b711f..c57d206184 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -129,28 +129,24 @@ messages." (define-syntax name (lambda (x) - (define (augmented-format-string fmt) - (string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt))) - (syntax-case x () ((name (underscore fmt) args (... ...)) (and (string? (syntax->datum #'fmt)) (free-identifier=? #'underscore #'G_)) - (with-syntax ((fmt* (augmented-format-string #'fmt)) - (prefix (datum->syntax x prefix))) - #'(format (guix-warning-port) (gettext fmt*) - (program-name) (program-name) prefix + #'(begin + (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" + (program-name) (program-name) prefix) + (format (guix-warning-port) (gettext fmt) args (... ...)))) ((name (N-underscore singular plural n) args (... ...)) (and (string? (syntax->datum #'singular)) (string? (syntax->datum #'plural)) (free-identifier=? #'N-underscore #'N_)) - (with-syntax ((s (augmented-format-string #'singular)) - (p (augmented-format-string #'plural)) - (prefix (datum->syntax x prefix))) - #'(format (guix-warning-port) - (ngettext s p n %gettext-domain) - (program-name) (program-name) prefix + #'(begin + (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" + (program-name) (program-name) prefix) + (format (guix-warning-port) + (ngettext singular plural n %gettext-domain) args (... ...)))))))) (define-diagnostic warning "warning: ") ; emit a warning -- cgit v1.2.3 From 26a2021a1f7951818539353531d56d2e8338966e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Apr 2019 23:44:36 +0200 Subject: ui: Make diagnostic message prefix translatable. * guix/ui.scm (define-diagnostic): Expect PREFIX to be enclosed in 'G_'. Emit call to 'gettext' on PREFIX. (warning, info, report-error): Wrap prefix in 'G_'. --- guix/ui.scm | 63 ++++++++++++++++++++++++++++++++++--------------------------- 1 file changed, 35 insertions(+), 28 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index c57d206184..953cf9ea7f 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -124,35 +124,42 @@ ;;; ;;; Code: -(define-syntax-rule (define-diagnostic name prefix) - "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all +(define-syntax define-diagnostic + (syntax-rules () + "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all messages." - (define-syntax name - (lambda (x) - (syntax-case x () - ((name (underscore fmt) args (... ...)) - (and (string? (syntax->datum #'fmt)) - (free-identifier=? #'underscore #'G_)) - #'(begin - (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" - (program-name) (program-name) prefix) - (format (guix-warning-port) (gettext fmt) - args (... ...)))) - ((name (N-underscore singular plural n) args (... ...)) - (and (string? (syntax->datum #'singular)) - (string? (syntax->datum #'plural)) - (free-identifier=? #'N-underscore #'N_)) - #'(begin - (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" - (program-name) (program-name) prefix) - (format (guix-warning-port) - (ngettext singular plural n %gettext-domain) - args (... ...)))))))) - -(define-diagnostic warning "warning: ") ; emit a warning -(define-diagnostic info "") - -(define-diagnostic report-error "error: ") + ((_ name (G_ prefix)) + (define-syntax name + (lambda (x) + (syntax-case x () + ((name (underscore fmt) args (... ...)) + (and (string? (syntax->datum #'fmt)) + (free-identifier=? #'underscore #'G_)) + #'(begin + (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" + (program-name) (program-name) + (gettext prefix %gettext-domain)) + (format (guix-warning-port) (gettext fmt %gettext-domain) + args (... ...)))) + ((name (N-underscore singular plural n) args (... ...)) + (and (string? (syntax->datum #'singular)) + (string? (syntax->datum #'plural)) + (free-identifier=? #'N-underscore #'N_)) + #'(begin + (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" + (program-name) (program-name) + (gettext prefix %gettext-domain)) + (format (guix-warning-port) + (ngettext singular plural n %gettext-domain) + args (... ...)))))))))) + +;; XXX: This doesn't work well for right-to-left languages. +;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; +;; "~a" is a placeholder for that phrase. +(define-diagnostic warning (G_ "warning: ")) ;emit a warning +(define-diagnostic info (G_ "")) + +(define-diagnostic report-error (G_ "error: ")) (define-syntax-rule (leave args ...) "Emit an error message and exit." (begin -- cgit v1.2.3 From cc3697d5438a861f78a1e5ed57f592ea9ee327be Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Apr 2019 10:26:39 +0200 Subject: ui: Factorize 'print-diagnostic-prefix'. * guix/ui.scm (define-diagnostic): Emit call to 'print-diagnostic-prefix'. (print-diagnostic-prefix): New procedure. --- guix/ui.scm | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 953cf9ea7f..8893cc8eee 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -136,9 +136,7 @@ messages." (and (string? (syntax->datum #'fmt)) (free-identifier=? #'underscore #'G_)) #'(begin - (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" - (program-name) (program-name) - (gettext prefix %gettext-domain)) + (print-diagnostic-prefix prefix) (format (guix-warning-port) (gettext fmt %gettext-domain) args (... ...)))) ((name (N-underscore singular plural n) args (... ...)) @@ -146,9 +144,7 @@ messages." (string? (syntax->datum #'plural)) (free-identifier=? #'N-underscore #'N_)) #'(begin - (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" - (program-name) (program-name) - (gettext prefix %gettext-domain)) + (print-diagnostic-prefix prefix) (format (guix-warning-port) (ngettext singular plural n %gettext-domain) args (... ...)))))))))) @@ -166,6 +162,14 @@ messages." (report-error args ...) (exit 1))) +(define (print-diagnostic-prefix prefix) + "Print PREFIX as a diagnostic line prefix." + (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" + (program-name) (program-name) + (if (string-null? prefix) + prefix + (gettext prefix %gettext-domain)))) + (define (print-unbound-variable-error port key args default-printer) ;; Print unbound variable errors more nicely, and in the right language. (match args -- cgit v1.2.3 From 402627714b8ba75be48b1c8fbd46cfd4cfe8238f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Apr 2019 11:14:25 +0200 Subject: ui: Diagnostic procedures can display error location. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/ui.scm (define-diagnostic): Add optional 'location' parameter. Pass it to 'print-diagnostic-prefix'. (print-diagnostic-prefix): Add optional 'location' parameter and honor it. (report-load-error): Use 'report-error' and 'warning' instead of (format (current-error-port) …). --- guix/ui.scm | 64 +++++++++++++++++++++++++++++++------------------------------ 1 file changed, 33 insertions(+), 31 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 8893cc8eee..9c8f943ef1 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -132,22 +132,31 @@ messages." (define-syntax name (lambda (x) (syntax-case x () - ((name (underscore fmt) args (... ...)) + ((name location (underscore fmt) args (... ...)) (and (string? (syntax->datum #'fmt)) (free-identifier=? #'underscore #'G_)) #'(begin - (print-diagnostic-prefix prefix) + (print-diagnostic-prefix prefix location) (format (guix-warning-port) (gettext fmt %gettext-domain) args (... ...)))) - ((name (N-underscore singular plural n) args (... ...)) + ((name location (N-underscore singular plural n) + args (... ...)) (and (string? (syntax->datum #'singular)) (string? (syntax->datum #'plural)) (free-identifier=? #'N-underscore #'N_)) #'(begin - (print-diagnostic-prefix prefix) + (print-diagnostic-prefix prefix location) (format (guix-warning-port) (ngettext singular plural n %gettext-domain) - args (... ...)))))))))) + args (... ...)))) + ((name (underscore fmt) args (... ...)) + (free-identifier=? #'underscore #'G_) + #'(name #f (underscore fmt) args (... ...))) + ((name (N-underscore singular plural n) + args (... ...)) + (free-identifier=? #'N-underscore #'N_) + #'(name #f (N-underscore singular plural n) + args (... ...))))))))) ;; XXX: This doesn't work well for right-to-left languages. ;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; @@ -162,13 +171,16 @@ messages." (report-error args ...) (exit 1))) -(define (print-diagnostic-prefix prefix) +(define* (print-diagnostic-prefix prefix #:optional location) "Print PREFIX as a diagnostic line prefix." - (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" - (program-name) (program-name) - (if (string-null? prefix) - prefix - (gettext prefix %gettext-domain)))) + (let ((prefix (if (string-null? prefix) + prefix + (gettext prefix %gettext-domain)))) + (if location + (format (guix-warning-port) "~a: ~a" + (location->string location) prefix) + (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" + (program-name) (program-name) prefix)))) (define (print-unbound-variable-error port key args default-printer) ;; Print unbound variable errors more nicely, and in the right language. @@ -360,21 +372,15 @@ ARGS is the list of arguments received by the 'throw' handler." (apply throw args))) (('syntax-error proc message properties form . rest) (let ((loc (source-properties->location properties))) - (format (current-error-port) (G_ "~a: error: ~a~%") - (location->string loc) message))) + (report-error loc (G_ "~a~%") message))) (('unbound-variable _ ...) (report-unbound-variable-error args #:frame frame)) (('srfi-34 obj) (if (message-condition? obj) - (if (error-location? obj) - (format (current-error-port) - (G_ "~a: error: ~a~%") - (location->string (error-location obj)) - (gettext (condition-message obj) - %gettext-domain)) - (report-error (G_ "~a~%") - (gettext (condition-message obj) - %gettext-domain))) + (report-error (and (error-location? obj) + (error-location obj)) + (G_ "~a~%") + (gettext (condition-message obj) %gettext-domain)) (report-error (G_ "exception thrown: ~s~%") obj)) (when (fix-hint? obj) (display-hint (condition-fix-hint obj)))) @@ -398,8 +404,7 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." (warning (G_ "failed to load '~a': ~a~%") file (strerror err)))) (('syntax-error proc message properties form . rest) (let ((loc (source-properties->location properties))) - (format (current-error-port) (G_ "~a: warning: ~a~%") - (location->string loc) message))) + (warning loc (G_ "~a~%") message))) (('srfi-34 obj) (if (message-condition? obj) (warning (G_ "failed to load '~a': ~a~%") @@ -731,17 +736,14 @@ directories:~{ ~a~}~%") (cons (invoke-error-program c) (invoke-error-arguments c)))) ((and (error-location? c) (message-condition? c)) - (format (current-error-port) - (G_ "~a: error: ~a~%") - (location->string (error-location c)) - (gettext (condition-message c) %gettext-domain)) + (report-error (error-location c) (G_ "~a~%") + (gettext (condition-message c) %gettext-domain)) (when (fix-hint? c) (display-hint (condition-fix-hint c))) (exit 1)) ((and (message-condition? c) (fix-hint? c)) - (format (current-error-port) "~a: error: ~a~%" - (program-name) - (gettext (condition-message c) %gettext-domain)) + (report-error (G_ "~a~%") + (gettext (condition-message c) %gettext-domain)) (display-hint (condition-fix-hint c)) (exit 1)) ((message-condition? c) -- cgit v1.2.3 From 9e1e046040182d8c4bb6e847bcd331862f9015bb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Apr 2019 12:00:55 +0200 Subject: ui: Colorize diagnostics. * guix/ui.scm (define-diagnostic): Add 'colors' parameter and pass it to 'print-diagnostic-prefix'. (warning, info, report-error): Add extra argument. (%warning-colors, %info-colors, %error-colors): New variables. (print-diagnostic-prefix): Add #:colors parameter and honor it. --- guix/ui.scm | 42 +++++++++++++++++++++++++++++++++--------- 1 file changed, 33 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 9c8f943ef1..3869f77c15 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -29,6 +29,7 @@ (define-module (guix ui) #:use-module (guix i18n) + #:use-module (guix colors) #:use-module (guix gexp) #:use-module (guix sets) #:use-module (guix utils) @@ -128,7 +129,7 @@ (syntax-rules () "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all messages." - ((_ name (G_ prefix)) + ((_ name (G_ prefix) colors) (define-syntax name (lambda (x) (syntax-case x () @@ -136,7 +137,8 @@ messages." (and (string? (syntax->datum #'fmt)) (free-identifier=? #'underscore #'G_)) #'(begin - (print-diagnostic-prefix prefix location) + (print-diagnostic-prefix prefix location + #:colors colors) (format (guix-warning-port) (gettext fmt %gettext-domain) args (... ...)))) ((name location (N-underscore singular plural n) @@ -145,7 +147,8 @@ messages." (string? (syntax->datum #'plural)) (free-identifier=? #'N-underscore #'N_)) #'(begin - (print-diagnostic-prefix prefix location) + (print-diagnostic-prefix prefix location + #:colors colors) (format (guix-warning-port) (ngettext singular plural n %gettext-domain) args (... ...)))) @@ -161,26 +164,47 @@ messages." ;; XXX: This doesn't work well for right-to-left languages. ;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; ;; "~a" is a placeholder for that phrase. -(define-diagnostic warning (G_ "warning: ")) ;emit a warning -(define-diagnostic info (G_ "")) +(define-diagnostic warning (G_ "warning: ") %warning-colors) ;emit a warning +(define-diagnostic info (G_ "") %info-colors) +(define-diagnostic report-error (G_ "error: ") %error-colors) -(define-diagnostic report-error (G_ "error: ")) (define-syntax-rule (leave args ...) "Emit an error message and exit." (begin (report-error args ...) (exit 1))) -(define* (print-diagnostic-prefix prefix #:optional location) +(define %warning-colors '(BOLD MAGENTA)) +(define %info-colors '(BOLD CYAN)) +(define %error-colors '(BOLD RED)) + +(define* (print-diagnostic-prefix prefix #:optional location + #:key (colors '())) "Print PREFIX as a diagnostic line prefix." + (define color? + (color-output? (guix-warning-port))) + + (define location-color + (if color? + (cut colorize-string <> 'BOLD) + identity)) + + (define prefix-color + (if color? + (lambda (prefix) + (apply colorize-string prefix colors)) + identity)) + (let ((prefix (if (string-null? prefix) prefix (gettext prefix %gettext-domain)))) (if location (format (guix-warning-port) "~a: ~a" - (location->string location) prefix) + (location-color (location->string location)) + (prefix-color prefix)) (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" - (program-name) (program-name) prefix)))) + (program-name) (program-name) + (prefix-color prefix))))) (define (print-unbound-variable-error port key args default-printer) ;; Print unbound variable errors more nicely, and in the right language. -- cgit v1.2.3 From a7ae18b1b9a083a1fbc6c2037e45df2447f704ed Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Apr 2019 12:55:23 +0200 Subject: ui: Colorize hints. * guix/ui.scm (%info-colors): Remove CYAN. (%hint-colors): New variable. (display-hint): Adjust so that the "hint:" prefix is colorized. --- guix/ui.scm | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 3869f77c15..63977f3aec 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -175,8 +175,9 @@ messages." (exit 1))) (define %warning-colors '(BOLD MAGENTA)) -(define %info-colors '(BOLD CYAN)) +(define %info-colors '(BOLD)) (define %error-colors '(BOLD RED)) +(define %hint-colors '(BOLD CYAN)) (define* (print-diagnostic-prefix prefix #:optional location #:key (colors '())) @@ -357,11 +358,18 @@ VARIABLE and return it, or #f if none was found." (define* (display-hint message #:optional (port (current-error-port))) "Display MESSAGE, a l10n message possibly containing Texinfo markup, to PORT." - (format port (G_ "hint: ~a~%") - ;; XXX: We should arrange so that the initial indent is wider. - (parameterize ((%text-width (max 15 - (- (terminal-columns) 5)))) - (texi->plain-text message)))) + (define colorize + (if (color-output? port) + (lambda (str) + (apply colorize-string str %hint-colors)) + identity)) + + (display (colorize (G_ "hint: ")) port) + (display + ;; XXX: We should arrange so that the initial indent is wider. + (parameterize ((%text-width (max 15 (- (terminal-columns) 5)))) + (texi->plain-text message)) + port)) (define* (report-unbound-variable-error args #:key frame) "Return the given unbound-variable error, where ARGS is the list of 'throw' -- cgit v1.2.3 From 238589e566013a36df0347b200f8a6059398666c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Apr 2019 16:12:54 +0200 Subject: ui: Highlight diagnostic format string arguments. * guix/ui.scm (highlight-argument): New macro. (%highlight-argument): New procedure. (define-diagnostic): Use 'highlight-argument'. --- guix/ui.scm | 47 +++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 45 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 63977f3aec..c3612d92b4 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -125,6 +125,48 @@ ;;; ;;; Code: +(define-syntax highlight-argument + (lambda (s) + "Given FMT and ARG, expand ARG to a call that highlights it, provided FMT +is a trivial format string." + (define (trivial-format-string? fmt) + (define len + (string-length fmt)) + + (let loop ((start 0)) + (or (>= (+ 1 start) len) + (let ((tilde (string-index fmt #\~ start))) + (or (not tilde) + (case (string-ref fmt (+ tilde 1)) + ((#\a #\A #\%) (loop (+ tilde 2))) + (else #f))))))) + + ;; Be conservative: limit format argument highlighting to cases where the + ;; format string contains nothing but ~a escapes. If it contained ~s + ;; escapes, this strategy wouldn't work. + (syntax-case s () + ((_ "~a~%" arg) ;don't highlight whole messages + #'arg) + ((_ fmt arg) + (trivial-format-string? (syntax->datum #'fmt)) + #'(%highlight-argument arg)) + ((_ fmt arg) + #'arg)))) + +(define* (%highlight-argument arg #:optional (port (guix-warning-port))) + "Highlight ARG, a format string argument, if PORT supports colors." + (define highlight + (if (color-output? port) + (lambda (str) + (apply colorize-string str %highlight-colors)) + identity)) + + (cond ((string? arg) + (highlight arg)) + ((symbol? arg) + (highlight (symbol->string arg))) + (else arg))) + (define-syntax define-diagnostic (syntax-rules () "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all @@ -140,7 +182,7 @@ messages." (print-diagnostic-prefix prefix location #:colors colors) (format (guix-warning-port) (gettext fmt %gettext-domain) - args (... ...)))) + (highlight-argument fmt args) (... ...)))) ((name location (N-underscore singular plural n) args (... ...)) (and (string? (syntax->datum #'singular)) @@ -151,7 +193,7 @@ messages." #:colors colors) (format (guix-warning-port) (ngettext singular plural n %gettext-domain) - args (... ...)))) + (highlight-argument singular args) (... ...)))) ((name (underscore fmt) args (... ...)) (free-identifier=? #'underscore #'G_) #'(name #f (underscore fmt) args (... ...))) @@ -178,6 +220,7 @@ messages." (define %info-colors '(BOLD)) (define %error-colors '(BOLD RED)) (define %hint-colors '(BOLD CYAN)) +(define %highlight-colors '(BOLD)) (define* (print-diagnostic-prefix prefix #:optional location #:key (colors '())) -- cgit v1.2.3 From 08d0f950b3ad936b859064c070be16548684cbd1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Apr 2019 16:13:51 +0200 Subject: pull: Remove duplicate '--dry-run' description. Reported by pkill9. * guix/scripts/pull.scm (show-help): Remove duplicate '--dry-run' description. --- guix/scripts/pull.scm | 2 -- 1 file changed, 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 2aaf1cc44a..55137fce8f 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -91,8 +91,6 @@ Download and deploy the latest version of Guix.\n")) (display (G_ " -p, --profile=PROFILE use PROFILE instead of ~/.config/guix/current")) (display (G_ " - -n, --dry-run show what would be pulled and built")) - (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) -- cgit v1.2.3 From 72eda0624be89ed18302fd7d7f22976071ab020c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Apr 2019 22:27:57 +0200 Subject: Add (guix store roots). * guix/store/roots.scm, tests/store-roots.scm: New files. * Makefile.am (STORE_MODULES): Add guix/store/roots.scm. (SCM_TESTS): Add tests/store-roots.scm. --- Makefile.am | 6 ++- guix/store/roots.scm | 120 ++++++++++++++++++++++++++++++++++++++++++++++++++ tests/store-roots.scm | 53 ++++++++++++++++++++++ 3 files changed, 177 insertions(+), 2 deletions(-) create mode 100644 guix/store/roots.scm create mode 100644 tests/store-roots.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 87682b4949..704f2451c3 100644 --- a/Makefile.am +++ b/Makefile.am @@ -277,7 +277,8 @@ endif BUILD_DAEMON_OFFLOAD # Scheme implementation of the build daemon and related functionality. STORE_MODULES = \ guix/store/database.scm \ - guix/store/deduplication.scm + guix/store/deduplication.scm \ + guix/store/roots.scm MODULES += $(STORE_MODULES) @@ -408,7 +409,8 @@ SCM_TESTS = \ tests/pypi.scm \ tests/import-utils.scm \ tests/store-database.scm \ - tests/store-deduplication.scm + tests/store-deduplication.scm \ + tests/store-roots.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/guix/store/roots.scm b/guix/store/roots.scm new file mode 100644 index 0000000000..4f23ae34e8 --- /dev/null +++ b/guix/store/roots.scm @@ -0,0 +1,120 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix store roots) + #:use-module (guix config) + #:use-module ((guix store) #:select (store-path? %gc-roots-directory)) + #:use-module (guix sets) + #:use-module (guix build syscalls) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:re-export (%gc-roots-directory) + #:export (gc-roots + user-owned?)) + +;;; Commentary: +;;; +;;; This module provides tools to list and access garbage collector roots ("GC +;;; roots"). +;;; +;;; Code: + +(define %profile-directory + ;; Directory where user profiles are stored. + ;; XXX: This is redundant with the definition in (guix profiles) and not + ;; entirely needed since in practice /var/guix/gcroots/profiles links to + ;; it. + (string-append %state-directory "/profiles")) + +(define (gc-roots) + "Return the list of garbage collector roots (\"GC roots\"). This includes +\"regular\" roots fount in %GC-ROOTS-DIRECTORY as well as indirect roots that +are user-controlled symlinks stored anywhere on the file system." + (define (regular? file) + (match file + (((or "." "..") . _) #f) + (_ #t))) + + (define (file-type=? type) + (match-lambda + ((file . properties) + (match (assq-ref properties 'type) + ('unknown + (let ((stat (lstat file))) + (eq? type (stat:type stat)))) + (actual-type + (eq? type actual-type)))))) + + (define directory? + (file-type=? 'directory)) + + (define symlink? + (file-type=? 'symlink)) + + (define canonical-root + (match-lambda + ((file . properties) + (let ((target (readlink file))) + (cond ((store-path? target) + ;; Regular root: FILE points to the store. + file) + + ;; Indirect root: FILE points to a user-controlled file outside + ;; the store. + ((string-prefix? "/" target) + target) + (else + (string-append (dirname file) "/" target))))))) + + (let loop ((directories (list %gc-roots-directory + %profile-directory)) + (roots '()) + (visited (set))) + (match directories + (() + roots) + ((directory . rest) + (if (set-contains? visited directory) + (loop rest roots visited) + (let*-values (((scope) + (cut string-append directory "/" <>)) + ((sub-directories files) + (partition directory? + (map (match-lambda + ((file . properties) + (cons (scope file) properties))) + (scandir* directory regular?))))) + (loop (append rest (map first sub-directories)) + (append (map canonical-root (filter symlink? files)) + roots) + (set-insert directory visited)))))))) + +(define* (user-owned? root #:optional (uid (getuid))) + "Return true if ROOT exists and is owned by UID, false otherwise." + ;; If ROOT is an indirect root, then perhaps it no longer exists. Thus, + ;; catch 'system-error' exceptions. + (catch 'system-error + (lambda () + (define stat + (lstat root)) + + (= (stat:uid stat) uid)) + (const #f))) diff --git a/tests/store-roots.scm b/tests/store-roots.scm new file mode 100644 index 0000000000..5bcf1bc87e --- /dev/null +++ b/tests/store-roots.scm @@ -0,0 +1,53 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; 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 . + +(define-module (test-store-deduplication) + #:use-module (guix tests) + #:use-module (guix store) + #:use-module (guix store roots) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +(define %store + (open-connection)) + +(test-begin "store-roots") + +(test-assert "gc-roots, regular root" + (let* ((item (add-text-to-store %store "something" + (random-text))) + (root (string-append %gc-roots-directory "/test-gc-root"))) + (symlink item root) + (let ((result (member root (gc-roots)))) + (delete-file root) + result))) + +(test-assert "gc-roots, indirect root" + (call-with-temporary-directory + (lambda (directory) + (let* ((item (add-text-to-store %store "something" + (random-text))) + (root (string-append directory "/gc-root"))) + (symlink item root) + (add-indirect-root %store root) + (let ((result (member root (gc-roots)))) + (delete-file root) + result))))) + +(test-end "store-roots") -- cgit v1.2.3 From bacf980c76c94e7bda86220ca4bf662d0e34a45a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Apr 2019 22:29:18 +0200 Subject: guix gc: Add '--list-roots'. * guix/scripts/gc.scm (show-help, %options): Add '--list-roots'. (guix-gc)[list-roots]: New procedure. Handle '--list-roots'. * tests/guix-gc.sh: Test it. * doc/guix.texi (Invoking guix gc): Document it. --- doc/guix.texi | 6 +++++- guix/scripts/gc.scm | 21 ++++++++++++++++++++- tests/guix-gc.sh | 6 ++++-- 3 files changed, 29 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 2f9fcbe3bf..2345617b2e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3385,7 +3385,7 @@ deleted. The set of garbage collector roots (``GC roots'' for short) includes default user profiles; by default, the symlinks under @file{/var/guix/gcroots} represent these GC roots. New GC roots can be added with @command{guix build --root}, for example (@pxref{Invoking -guix build}). +guix build}). The @command{guix gc --list-roots} command lists them. Prior to running @code{guix gc --collect-garbage} to make space, it is often useful to remove old generations from user profiles; that way, old @@ -3451,6 +3451,10 @@ This prints nothing unless the daemon was started with @option{--cache-failures} (@pxref{Invoking guix-daemon, @option{--cache-failures}}). +@item --list-roots +List the GC roots owned by the user; when run as root, list @emph{all} the GC +roots. + @item --clear-failures Remove the specified store items from the failed-build cache. diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 6f37b767ff..2606e20deb 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 Ludovic Courtès +;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix store) + #:use-module (guix store roots) #:autoload (guix build syscalls) (free-disk-space) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -48,6 +49,8 @@ Invoke the garbage collector.\n")) -F, --free-space=FREE attempt to reach FREE available space in the store")) (display (G_ " -d, --delete attempt to delete PATHS")) + (display (G_ " + --list-roots list the user's garbage collector roots")) (display (G_ " --optimize optimize the store by deduplicating identical files")) (display (G_ " @@ -135,6 +138,10 @@ Invoke the garbage collector.\n")) (alist-cons 'verify-options options (alist-delete 'action result)))))) + (option '("list-roots") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-roots + (alist-delete 'action result)))) (option '("list-dead") #f #f (lambda (opt name arg result) (alist-cons 'action 'list-dead @@ -205,6 +212,15 @@ Invoke the garbage collector.\n")) (info (G_ "freeing ~h MiBs~%") (/ to-free 1024. 1024.)) (collect-garbage store to-free))))) + (define (list-roots) + ;; List all the user-owned GC roots. + (let ((roots (filter (if (zero? (getuid)) (const #t) user-owned?) + (gc-roots)))) + (for-each (lambda (root) + (display root) + (newline)) + roots))) + (with-error-handling (let* ((opts (parse-options)) (store (open-connection)) @@ -238,6 +254,9 @@ Invoke the garbage collector.\n")) (else (let-values (((paths freed) (collect-garbage store))) (info (G_ "freed ~h MiBs~%") (/ freed 1024. 1024.))))))) + ((list-roots) + (assert-no-extra-arguments) + (list-roots)) ((delete) (delete-paths store (map direct-store-path paths))) ((list-references) diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh index ef2d9543b7..8284287730 100644 --- a/tests/guix-gc.sh +++ b/tests/guix-gc.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2013, 2015, 2017, 2018 Ludovic Courtès +# Copyright © 2013, 2015, 2017, 2018, 2019 Ludovic Courtès # # This file is part of GNU Guix. # @@ -34,7 +34,7 @@ unset drv unset out # For some operations, passing extra arguments is an error. -for option in "" "-C 500M" "--verify" "--optimize" +for option in "" "-C 500M" "--verify" "--optimize" "--list-roots" do if guix gc $option whatever; then false; else true; fi done @@ -69,6 +69,8 @@ guix gc --delete "$drv" drv="`guix build --root=guix-gc-root lsh -d`" test -f "$drv" && test -L guix-gc-root +guix gc --list-roots | grep "$PWD/guix-gc-root" + guix gc --list-live | grep "$drv" if guix gc --delete "$drv"; then false; else true; fi -- cgit v1.2.3 From c872b952c527cb42766654d12059d5ea5224ca6c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Apr 2019 23:05:27 +0200 Subject: profiles: Add 'generation-profile'. * guix/profiles.scm (%profile-generation-rx): New variable. (generation-profile): New procedure. --- guix/profiles.scm | 15 +++++++++++++++ 1 file changed, 15 insertions(+) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 6564526aee..dfc9ba1ca0 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -118,6 +118,7 @@ profile-search-paths generation-number + generation-profile generation-numbers profile-generations relative-generation-spec->number @@ -1552,6 +1553,20 @@ already effective." (compose string->number (cut match:substring <> 1))) 0)) +(define %profile-generation-rx + ;; Regexp that matches profile generation. + (make-regexp "(.*)-([0-9]+)-link$")) + +(define (generation-profile file) + "If FILE is a profile generation GC root such as \"guix-profile-42-link\", +return its corresponding profile---e.g., \"guix-profile\". Otherwise return +#f." + (match (regexp-exec %profile-generation-rx file) + (#f #f) + (m (let ((profile (match:substring m 1))) + (and (file-exists? (string-append profile "/manifest")) + profile))))) + (define (generation-numbers profile) "Return the sorted list of generation numbers of PROFILE, or '(0) if no former profiles were found." -- cgit v1.2.3 From 96b8c2e6e2aa00b7b400530b62cf7479aa2d9674 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Apr 2019 23:14:19 +0200 Subject: guix gc: Add '--delete-generations'. * guix/scripts/gc.scm (show-help, %options): Add '--delete-generations'. Change '--delete' shorthand to '-D'. (delete-old-generations): New procedure. (guix-gc)[delete-generations]: New procedure. Call it when ACTION is 'collect-garbage' and OPTS contains 'delete-generations. * doc/guix.texi (Invoking guix gc): Document it. --- doc/guix.texi | 16 +++++++++++++++- guix/scripts/gc.scm | 46 ++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 59 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 2345617b2e..406bea34d1 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3438,8 +3438,22 @@ as @code{500MiB}, as described above. When @var{free} or more is already available in @file{/gnu/store}, do nothing and exit immediately. +@item --delete-generations[=@var{duration}] +@itemx -d [@var{duration}] +Before starting the garbage collection process, delete all the generations +older than @var{duration}, for all the user profiles; when run as root, this +applies to all the profiles @emph{of all the users}. + +For example, this command deletes all the generations of all your profiles +that are older than 2 months (except generations that are current), and then +proceeds to free space until at least 10 GiB are available: + +@example +guix gc -d 2m -F 10G +@end example + @item --delete -@itemx -d +@itemx -D Attempt to delete all the store files and directories specified as arguments. This fails if some of the files are not in the store, or if they are still live. diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 2606e20deb..00f1eb8d00 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -22,6 +22,8 @@ #:use-module (guix store) #:use-module (guix store roots) #:autoload (guix build syscalls) (free-disk-space) + #:autoload (guix profiles) (generation-profile) + #:autoload (guix scripts package) (delete-generations) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) @@ -48,7 +50,10 @@ Invoke the garbage collector.\n")) (display (G_ " -F, --free-space=FREE attempt to reach FREE available space in the store")) (display (G_ " - -d, --delete attempt to delete PATHS")) + -d, --delete-generations[=PATTERN] + delete profile generations matching PATTERN")) + (display (G_ " + -D, --delete attempt to delete PATHS")) (display (G_ " --list-roots list the user's garbage collector roots")) (display (G_ " @@ -98,6 +103,16 @@ Invoke the garbage collector.\n")) lst) '())))) +(define (delete-old-generations store profile pattern) + "Remove the generations of PROFILE that match PATTERN, a duration pattern. +Do nothing if none matches." + (let* ((current (generation-number profile)) + (numbers (matching-generations pattern profile + #:duration-relation >))) + + ;; Make sure we don't inadvertently remove the current generation. + (delete-generations store profile (delv current numbers)))) + (define %options ;; Specification of the command-line options. (list (option '(#\h "help") #f #f @@ -123,10 +138,25 @@ Invoke the garbage collector.\n")) (option '(#\F "free-space") #t #f (lambda (opt name arg result) (alist-cons 'free-space (size->number arg) result))) - (option '(#\d "delete") #f #f + (option '(#\D "delete") #f #f ;used to be '-d' (lower case) (lambda (opt name arg result) (alist-cons 'action 'delete (alist-delete 'action result)))) + (option '(#\d "delete-generations") #f #t + (lambda (opt name arg result) + (if (and arg (store-path? arg)) + (begin + (warning (G_ "'-d' as an alias for '--delete' \ +is deprecated; use '-D'~%")) + `((action . delete) + (argument . ,arg) + (alist-delete 'action result))) + (begin + (when (and arg (not (string->duration arg))) + (leave (G_ "~s does not denote a duration~%") + arg)) + (alist-cons 'delete-generations (or arg "") + result))))) (option '("optimize") #f #f (lambda (opt name arg result) (alist-cons 'action 'optimize @@ -212,6 +242,14 @@ Invoke the garbage collector.\n")) (info (G_ "freeing ~h MiBs~%") (/ to-free 1024. 1024.)) (collect-garbage store to-free))))) + (define (delete-generations store pattern) + ;; Delete the generations matching PATTERN of all the user's profiles. + (let ((profiles (delete-duplicates + (filter-map generation-profile (gc-roots))))) + (for-each (lambda (profile) + (delete-old-generations store profile pattern)) + profiles))) + (define (list-roots) ;; List all the user-owned GC roots. (let ((roots (filter (if (zero? (getuid)) (const #t) user-owned?) @@ -245,6 +283,10 @@ Invoke the garbage collector.\n")) (assert-no-extra-arguments) (let ((min-freed (assoc-ref opts 'min-freed)) (free-space (assoc-ref opts 'free-space))) + (match (assoc-ref opts 'delete-generations) + (#f #t) + ((? string? pattern) + (delete-generations store pattern))) (cond (free-space (ensure-free-space store free-space)) -- cgit v1.2.3 From 9c074f61ef1883ae01fcb9daa0c199c46b1ea584 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Apr 2019 23:19:36 +0200 Subject: scripts: GC hint suggests 'guix gc -d 1m'. * guix/scripts.scm (warn-about-disk-space): Suggest 'guix gc -d'. --- guix/scripts.scm | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/scripts.scm b/guix/scripts.scm index e4b11d295d..77cbf12350 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -201,16 +201,12 @@ available." (when (< ratio threshold) (warning (G_ "only ~,1f% of free space available on ~a~%") (* ratio 100) (%store-prefix)) - (if profile - (display-hint (format #f (G_ "Consider deleting old profile + (display-hint (format #f (G_ "Consider deleting old profile generations and collecting garbage, along these lines: @example -guix package -p ~s --delete-generations=1m -guix gc +guix gc --delete-generations=1m @end example\n") - profile)) - (display-hint (G_ "Consider running @command{guix gc} to free -space.")))))) + profile))))) ;;; scripts.scm ends here -- cgit v1.2.3 From 3e159dd0a46ba785f8a09bd86e6cacb5c1708bc9 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Wed, 3 Apr 2019 20:11:54 +0200 Subject: import: opam: Add more patterns to opam file parser. * guix/import/opam.scm: Add more patterns to peg parser. (choice-pat choice condition-not condition-paren): New patterns. (ground-value condition-content condition-var): Update patterns. --- guix/import/opam.scm | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/import/opam.scm b/guix/import/opam.scm index 36028a01d6..b5069cd2f3 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -58,7 +58,12 @@ (define-peg-pattern weird-record all (and key (* SP) dict)) (define-peg-pattern key body (+ (or (range #\a #\z) "-"))) (define-peg-pattern value body (and (or conditional-value ground-value operator) (* SP))) -(define-peg-pattern ground-value body (and (or multiline-string string-pat list-pat var) (* SP))) +(define-peg-pattern choice-pat all (and (ignore "(") (* SP) choice (* SP) (ignore ")"))) +(define-peg-pattern choice body + (or (and (or conditional-value ground-value) (* SP) (ignore "|") (* SP) choice) + conditional-value + ground-value)) +(define-peg-pattern ground-value body (and (or multiline-string string-pat choice-pat list-pat var) (* SP))) (define-peg-pattern conditional-value all (and ground-value (* SP) condition)) (define-peg-pattern string-pat all (and QUOTE (* STRCHR) QUOTE)) (define-peg-pattern list-pat all (and (ignore "[") (* SP) (* (and value (* SP))) (ignore "]"))) @@ -80,7 +85,8 @@ (define-peg-pattern condition-form2 body (and (* SP) (or condition-greater-or-equal condition-greater condition-lower-or-equal condition-lower - condition-neq condition-eq condition-content) (* SP))) + condition-neq condition-eq condition-not + condition-content) (* SP))) ;(define-peg-pattern condition-operator all (and (ignore operator) (* SP) condition-string)) (define-peg-pattern condition-greater-or-equal all (and (ignore (and ">" "=")) (* SP) condition-string)) @@ -91,10 +97,12 @@ (define-peg-pattern condition-or all (and condition-form2 (* SP) (ignore "|") (* SP) condition-form)) (define-peg-pattern condition-eq all (and (? condition-content) (* SP) (ignore "=") (* SP) condition-content)) (define-peg-pattern condition-neq all (and (? condition-content) (* SP) (ignore (and "!" "=")) (* SP) condition-content)) -(define-peg-pattern condition-content body (or condition-string condition-var)) +(define-peg-pattern condition-not all (and (ignore (and "!")) (* SP) condition-content)) +(define-peg-pattern condition-content body (or condition-paren condition-string condition-var)) (define-peg-pattern condition-content2 body (and condition-content (* SP) (not-followed-by (or "&" "=" "!")))) +(define-peg-pattern condition-paren body (and "(" condition-form ")")) (define-peg-pattern condition-string all (and QUOTE (* STRCHR) QUOTE)) -(define-peg-pattern condition-var all (+ (or (range #\a #\z) "-"))) +(define-peg-pattern condition-var all (+ (or (range #\a #\z) "-" ":"))) (define (get-opam-repository) "Update or fetch the latest version of the opam repository and return the @@ -171,18 +179,24 @@ path to the repository." (define (dependency->input dependency) (match dependency (('string-pat str) str) + ;; Arbitrary select the first dependency + (('choice-pat choice ...) (dependency->input (car choice))) (('conditional-value val condition) (if (native? condition) "" (dependency->input val))))) (define (dependency->native-input dependency) (match dependency (('string-pat str) "") + ;; Arbitrary select the first dependency + (('choice-pat choice ...) (dependency->input (car choice))) (('conditional-value val condition) (if (native? condition) (dependency->input val) "")))) (define (dependency->name dependency) (match dependency (('string-pat str) str) + ;; Arbitrary select the first dependency + (('choice-pat choice ...) (dependency->input (car choice))) (('conditional-value val condition) (dependency->name val)))) -- cgit v1.2.3 From 7b1c7ecdfbe26b56dbb19aa82874f3ef2df8ab08 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Wed, 3 Apr 2019 20:19:24 +0200 Subject: import: opam: Use dune-build-system when possible. * guix/import/opam.scm (opam->guix-package): Detect when dune can be used. --- guix/import/opam.scm | 80 +++++++++++++++++++++++++++++++--------------------- 1 file changed, 48 insertions(+), 32 deletions(-) (limited to 'guix') diff --git a/guix/import/opam.scm b/guix/import/opam.scm index b5069cd2f3..5dcc0e97a3 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -247,39 +247,55 @@ path to the repository." (url-dict (metadata-ref opam-content "url")) (source-url (metadata-ref url-dict "src")) (requirements (metadata-ref opam-content "depends")) - (dependencies (dependency-list->names requirements)) + (dependencies (filter + (lambda (name) + (not (member name '("dune" "jbuilder")))) + (dependency-list->names requirements))) + (native-dependencies (depends->native-inputs requirements)) (inputs (dependency-list->inputs (depends->inputs requirements))) - (native-inputs (dependency-list->inputs (depends->native-inputs requirements)))) - (call-with-temporary-output-file - (lambda (temp port) - (and (url-fetch source-url temp) - (values - `(package - (name ,(ocaml-name->guix-name name)) - (version ,(if (string-prefix? "v" version) - (substring version 1) - version)) - (source - (origin - (method url-fetch) - (uri ,source-url) - (sha256 (base32 ,(guix-hash-url temp))))) - (build-system ocaml-build-system) - ,@(if (null? inputs) - '() - `((inputs ,(list 'quasiquote inputs)))) - ,@(if (null? native-inputs) - '() - `((native-inputs ,(list 'quasiquote native-inputs)))) - ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name))) - '() - `((properties - ,(list 'quasiquote `((upstream-name . ,name)))))) - (home-page ,(metadata-ref opam-content "homepage")) - (synopsis ,(metadata-ref opam-content "synopsis")) - (description ,(metadata-ref opam-content "description")) - (license #f)) - dependencies)))))) + (native-inputs (dependency-list->inputs + ;; Do not add dune nor jbuilder since they are + ;; implicit inputs of the dune-build-system. + (filter + (lambda (name) + (not (member name '("dune" "jbuilder")))) + native-dependencies)))) + ;; If one of these are required at build time, it means we + ;; can use the much nicer dune-build-system. + (let ((use-dune? (or (member "dune" native-dependencies) + (member "jbuilder" native-dependencies)))) + (call-with-temporary-output-file + (lambda (temp port) + (and (url-fetch source-url temp) + (values + `(package + (name ,(ocaml-name->guix-name name)) + (version ,(if (string-prefix? "v" version) + (substring version 1) + version)) + (source + (origin + (method url-fetch) + (uri ,source-url) + (sha256 (base32 ,(guix-hash-url temp))))) + (build-system ,(if use-dune? + 'dune-build-system + 'ocaml-build-system)) + ,@(if (null? inputs) + '() + `((inputs ,(list 'quasiquote inputs)))) + ,@(if (null? native-inputs) + '() + `((native-inputs ,(list 'quasiquote native-inputs)))) + ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name))) + '() + `((properties + ,(list 'quasiquote `((upstream-name . ,name)))))) + (home-page ,(metadata-ref opam-content "homepage")) + (synopsis ,(metadata-ref opam-content "synopsis")) + (description ,(metadata-ref opam-content "description")) + (license #f)) + dependencies))))))) (define (opam-recursive-import package-name) (recursive-import package-name #f -- cgit v1.2.3 From ce6312999f20bb8d7e73c29b315747b1f4d184aa Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Fri, 5 Apr 2019 11:41:17 +0200 Subject: Add (guix build-system linux-module). * guix/build/linux-module-build-system.scm: New file. * guix/build-system/linux-module.scm: New file. * doc/guix.texi (Build Systems): Document it. * Makefile.am (MODULES): Add them. --- Makefile.am | 2 + doc/guix.texi | 27 +++++ guix/build-system/linux-module.scm | 166 +++++++++++++++++++++++++++++++ guix/build/linux-module-build-system.scm | 78 +++++++++++++++ 4 files changed, 273 insertions(+) create mode 100644 guix/build-system/linux-module.scm create mode 100644 guix/build/linux-module-build-system.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 704f2451c3..8d523262cb 100644 --- a/Makefile.am +++ b/Makefile.am @@ -120,6 +120,7 @@ MODULES = \ guix/build-system/gnu.scm \ guix/build-system/guile.scm \ guix/build-system/haskell.scm \ + guix/build-system/linux-module.scm \ guix/build-system/perl.scm \ guix/build-system/python.scm \ guix/build-system/ocaml.scm \ @@ -173,6 +174,7 @@ MODULES = \ guix/build/texlive-build-system.scm \ guix/build/waf-build-system.scm \ guix/build/haskell-build-system.scm \ + guix/build/linux-module-build-system.scm \ guix/build/store-copy.scm \ guix/build/utils.scm \ guix/build/union.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 7dc4e1894a..9be7d9a27b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6210,6 +6210,33 @@ is not enabled by default. It can be enabled with @code{#:glib-or-gtk?}. @end table @end defvr +@defvr {Scheme Variable} linux-module-build-system +@var{linux-module-build-system} allows building Linux kernel modules. + +@cindex build phases +This build system is an extension of @var{gnu-build-system}, but with the +following phases changed: + +@table @code + +@item configure +This phase configures the environment so that the Linux kernel's Makefile +can be used to build the external kernel module. + +@item build +This phase uses the Linux kernel's Makefile in order to build the external +kernel module. + +@item install +This phase uses the Linux kernel's Makefile in order to install the external +kernel module. +@end table + +It is possible and useful to specify the Linux kernel to use for building +the module (in the "arguments" form of a package using the +linux-module-build-system, use the key #:linux to specify it). +@end defvr + Lastly, for packages that do not need anything as sophisticated, a ``trivial'' build system is provided. It is trivial in the sense that it provides basically no support: it does not pull any implicit inputs, diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm new file mode 100644 index 0000000000..3ed3351353 --- /dev/null +++ b/guix/build-system/linux-module.scm @@ -0,0 +1,166 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Danny Milosavljevic +;;; +;;; 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 . + +(define-module (guix build-system linux-module) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (guix packages) + #:use-module (ice-9 match) + #:export (%linux-module-build-system-modules + linux-module-build + linux-module-build-system)) + +;; Commentary: +;; +;; Code: + +(define %linux-module-build-system-modules + ;; Build-side modules imported by default. + `((guix build linux-module-build-system) + ,@%gnu-build-system-modules)) + +(define (default-linux) + "Return the default Linux package." + + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages linux)))) + (module-ref module 'linux-libre))) + +(define (default-kmod) + "Return the default kmod package." + + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages linux)))) + (module-ref module 'kmod))) + +(define (default-gcc) + "Return the default gcc package." + + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages gcc)))) + (module-ref module 'gcc-7))) + +(define (make-linux-module-builder linux) + (package + (inherit linux) + (name (string-append (package-name linux) "-module-builder")) + (arguments + (substitute-keyword-arguments (package-arguments linux) + ((#:phases phases) + `(modify-phases ,phases + (replace 'build + (lambda _ + (invoke "make" "modules_prepare"))) + (delete 'strip) ; faster. + (replace 'install + (lambda* (#:key outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (out-lib-build (string-append out "/lib/modules/build"))) + ; TODO: Only preserve the minimum, i.e. [Kbuild], Kconfig, scripts, include, ".config". + (copy-recursively "." out-lib-build) + #t))))))))) + +(define* (lower name + #:key source inputs native-inputs outputs + system target + (linux (default-linux)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:source #:target #:gcc #:kmod #:linux #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + ,@(standard-packages))) + (build-inputs `(("linux" ,linux) ; for "Module.symvers". + ("linux-module-builder" + ,(make-linux-module-builder linux)) + ,@native-inputs + ;; TODO: Remove "gmp", "mpfr", "mpc" since they are only needed to compile the gcc plugins. Maybe remove "flex", "bison", "elfutils", "perl", "openssl". That leaves very little ("bc", "gcc", "kmod"). + ,@(package-native-inputs linux))) + (outputs outputs) + (build linux-module-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (linux-module-build store name inputs + #:key + (search-paths '()) + (tests? #t) + (phases '(@ (guix build linux-module-build-system) + %standard-phases)) + (outputs '("out")) + (system (%current-system)) + (guile #f) + (imported-modules + %linux-module-build-system-modules) + (modules '((guix build linux-module-build-system) + (guix build utils)))) + "Build SOURCE using LINUX, and with INPUTS." + (define builder + `(begin + (use-modules ,@modules) + (linux-module-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:phases ,phases + #:system ,system + #:tests? ,tests? + #:outputs %outputs + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:system system + #:inputs inputs + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define linux-module-build-system + (build-system + (name 'linux-module) + (description "The Linux module build system") + (lower lower))) + +;;; linux-module.scm ends here diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm new file mode 100644 index 0000000000..a6664f1eca --- /dev/null +++ b/guix/build/linux-module-build-system.scm @@ -0,0 +1,78 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Danny Milosavljevic +;;; +;;; 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 . + +(define-module (guix build linux-module-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + linux-module-build)) + +;; Commentary: +;; +;; Builder-side code of linux-module build. +;; +;; Code: + +;; TODO: It might make sense to provide "Module.symvers" in the future. +(define* (configure #:key inputs #:allow-other-keys) + #t) + +(define* (build #:key inputs make-flags #:allow-other-keys) + (apply invoke "make" "-C" + (string-append (assoc-ref inputs "linux-module-builder") + "/lib/modules/build") + (string-append "M=" (getcwd)) + (or make-flags '()))) + +;; This block was copied from make-linux-libre--only took the "modules_install" +;; part. +(define* (install #:key inputs native-inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (moddir (string-append out "/lib/modules")) + (kmod (assoc-ref (or native-inputs inputs) "kmod"))) + ;; Install kernel modules + (mkdir-p moddir) + (invoke "make" "-C" + (string-append (assoc-ref inputs "linux-module-builder") + "/lib/modules/build") + (string-append "M=" (getcwd)) + (string-append "DEPMOD=" kmod "/bin/depmod") + (string-append "MODULE_DIR=" moddir) + (string-append "INSTALL_PATH=" out) + (string-append "INSTALL_MOD_PATH=" out) + "INSTALL_MOD_STRIP=1" + "modules_install"))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (replace 'configure configure) + (replace 'build build) + (replace 'install install))) + +(define* (linux-module-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given package, applying all of PHASES in order, with a Linux kernel in attendance." + (apply gnu:gnu-build + #:inputs inputs #:phases phases + args)) + +;;; linux-module-build-system.scm ends here -- cgit v1.2.3 From c1df77e215b6e69dccbe781307836a3b962c5968 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Apr 2019 16:55:13 +0200 Subject: guix gc: '-d' does not attempt to delete non-user-owned roots. * guix/scripts/gc.scm (guix-gc)[delete-generations]: Limit to user-owned roots, unless we're running as root. --- guix/scripts/gc.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 00f1eb8d00..9a57e5fd1e 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -245,7 +245,11 @@ is deprecated; use '-D'~%")) (define (delete-generations store pattern) ;; Delete the generations matching PATTERN of all the user's profiles. (let ((profiles (delete-duplicates - (filter-map generation-profile (gc-roots))))) + (filter-map (lambda (root) + (and (or (zero? (getuid)) + (user-owned? root)) + (generation-profile root))) + (gc-roots))))) (for-each (lambda (profile) (delete-old-generations store profile pattern)) profiles))) -- cgit v1.2.3 From 2569ef9dab4f796a75b8cdddd57d3be37b142036 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Apr 2019 16:57:38 +0200 Subject: colors: Introduce a disjoint type and pre-compute ANSI escapes. * guix/colors.scm (color-table, color): Remove. (): New record type. (print-color): New procedure. (define-color-table, color): New macros. (color-codes->ansi): New procedure. (%reset): New variable. (colorize-string): Rewrite accordingly. (color-rules): Adjust accordingly. * guix/status.scm (print-build-event): Adjust to new 'colorize-string' interface. * guix/ui.scm (%highlight-argument): Likewise. (%warning-colors, %info-colors, %error-colors, %hint-colors) (%highlight-colors): Remove. (%warning-color, %info-color, %error-color, %hint-color) (%highlight-color): New variables. --- guix/colors.scm | 138 +++++++++++++++++++++++++++++++++++--------------------- guix/status.scm | 6 +-- guix/ui.scm | 26 +++++------ 3 files changed, 103 insertions(+), 67 deletions(-) (limited to 'guix') diff --git a/guix/colors.scm b/guix/colors.scm index fad0bd2ab9..b7d3f6d4ec 100644 --- a/guix/colors.scm +++ b/guix/colors.scm @@ -22,9 +22,14 @@ (define-module (guix colors) #:use-module (guix memoization) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:use-module (ice-9 match) #:use-module (ice-9 regex) - #:export (colorize-string + #:export (color + color? + + colorize-string color-rules color-output? isatty?*)) @@ -35,55 +40,86 @@ ;;; ;;; Code: -(define color-table - `((CLEAR . "0") - (RESET . "0") - (BOLD . "1") - (DARK . "2") - (UNDERLINE . "4") - (UNDERSCORE . "4") - (BLINK . "5") - (REVERSE . "6") - (CONCEALED . "8") - (BLACK . "30") - (RED . "31") - (GREEN . "32") - (YELLOW . "33") - (BLUE . "34") - (MAGENTA . "35") - (CYAN . "36") - (WHITE . "37") - (ON-BLACK . "40") - (ON-RED . "41") - (ON-GREEN . "42") - (ON-YELLOW . "43") - (ON-BLUE . "44") - (ON-MAGENTA . "45") - (ON-CYAN . "46") - (ON-WHITE . "47"))) - -(define (color . lst) - "Return a string containing the ANSI escape sequence for producing the -requested set of attributes in LST. Unknown attributes are ignored." - (let ((color-list - (remove not - (map (lambda (color) (assq-ref color-table color)) - lst)))) - (if (null? color-list) - "" - (string-append - (string #\esc #\[) - (string-join color-list ";" 'infix) - "m")))) - -(define (colorize-string str . color-list) - "Return a copy of STR colorized using ANSI escape sequences according to the -attributes STR. At the end of the returned string, the color attributes will -be reset such that subsequent output will not have any colors in effect." - (string-append - (apply color color-list) - str - (color 'RESET))) +;; Record type for "colors", which are actually lists of color attributes. +(define-record-type + (make-color symbols ansi) + color? + (symbols color-symbols) + (ansi color-ansi)) + +(define (print-color color port) + (format port "#" + (string-join (map symbol->string + (color-symbols color))))) + +(set-record-type-printer! print-color) + +(define-syntax define-color-table + (syntax-rules () + "Define NAME as a macro that builds a list of color attributes." + ((_ name (color escape) ...) + (begin + (define-syntax color-codes + (syntax-rules (color ...) + ((_) + '()) + ((_ color rest (... ...)) + `(escape ,@(color-codes rest (... ...)))) + ...)) + + (define-syntax-rule (name colors (... ...)) + "Return a list of color attributes that can be passed to +'colorize-string'." + (make-color '(colors (... ...)) + (color-codes->ansi (color-codes colors (... ...))))))))) + +(define-color-table color + (CLEAR "0") + (RESET "0") + (BOLD "1") + (DARK "2") + (UNDERLINE "4") + (UNDERSCORE "4") + (BLINK "5") + (REVERSE "6") + (CONCEALED "8") + (BLACK "30") + (RED "31") + (GREEN "32") + (YELLOW "33") + (BLUE "34") + (MAGENTA "35") + (CYAN "36") + (WHITE "37") + (ON-BLACK "40") + (ON-RED "41") + (ON-GREEN "42") + (ON-YELLOW "43") + (ON-BLUE "44") + (ON-MAGENTA "45") + (ON-CYAN "46") + (ON-WHITE "47")) + +(define (color-codes->ansi codes) + "Convert CODES, a list of color attribute codes, to a ANSI escape string." + (match codes + (() + "") + (_ + (string-append (string #\esc #\[) + (string-join codes ";" 'infix) + "m")))) + +(define %reset + (color RESET)) + +(define (colorize-string str color) + "Return a copy of STR colorized using ANSI escape sequences according to +COLOR. At the end of the returned string, the color attributes are reset such +that subsequent output will not have any colors in effect." + (string-append (color-ansi color) + str + (color-ansi %reset))) (define isatty?* (mlambdaq (port) @@ -114,7 +150,7 @@ on." (match (regexp-exec rx str) (#f (next str)) (m (let loop ((n 1) - (c '(colors ...)) + (c (list (color colors) ...)) (result '())) (match c (() diff --git a/guix/status.scm b/guix/status.scm index 7edb558ee7..cbea4151f2 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -410,17 +410,17 @@ produce colorful output. When PRINT-LOG? is true, display the build log in addition to build events." (define info (if colorize? - (cut colorize-string <> 'BOLD) + (cute colorize-string <> (color BOLD)) identity)) (define success (if colorize? - (cut colorize-string <> 'GREEN 'BOLD) + (cute colorize-string <> (color GREEN BOLD)) identity)) (define failure (if colorize? - (cut colorize-string <> 'RED 'BOLD) + (cute colorize-string <> (color RED BOLD)) identity)) (define (report-build-progress phase %) diff --git a/guix/ui.scm b/guix/ui.scm index c3612d92b4..2481a1b78b 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -158,7 +158,7 @@ is a trivial format string." (define highlight (if (color-output? port) (lambda (str) - (apply colorize-string str %highlight-colors)) + (colorize-string str %highlight-color)) identity)) (cond ((string? arg) @@ -206,9 +206,9 @@ messages." ;; XXX: This doesn't work well for right-to-left languages. ;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; ;; "~a" is a placeholder for that phrase. -(define-diagnostic warning (G_ "warning: ") %warning-colors) ;emit a warning -(define-diagnostic info (G_ "") %info-colors) -(define-diagnostic report-error (G_ "error: ") %error-colors) +(define-diagnostic warning (G_ "warning: ") %warning-color) ;emit a warning +(define-diagnostic info (G_ "") %info-color) +(define-diagnostic report-error (G_ "error: ") %error-color) (define-syntax-rule (leave args ...) "Emit an error message and exit." @@ -216,27 +216,27 @@ messages." (report-error args ...) (exit 1))) -(define %warning-colors '(BOLD MAGENTA)) -(define %info-colors '(BOLD)) -(define %error-colors '(BOLD RED)) -(define %hint-colors '(BOLD CYAN)) -(define %highlight-colors '(BOLD)) +(define %warning-color (color BOLD MAGENTA)) +(define %info-color (color BOLD)) +(define %error-color (color BOLD RED)) +(define %hint-color (color BOLD CYAN)) +(define %highlight-color (color BOLD)) (define* (print-diagnostic-prefix prefix #:optional location - #:key (colors '())) + #:key (colors (color))) "Print PREFIX as a diagnostic line prefix." (define color? (color-output? (guix-warning-port))) (define location-color (if color? - (cut colorize-string <> 'BOLD) + (cut colorize-string <> (color BOLD)) identity)) (define prefix-color (if color? (lambda (prefix) - (apply colorize-string prefix colors)) + (colorize-string prefix colors)) identity)) (let ((prefix (if (string-null? prefix) @@ -404,7 +404,7 @@ PORT." (define colorize (if (color-output? port) (lambda (str) - (apply colorize-string str %hint-colors)) + (colorize-string str %hint-color)) identity)) (display (colorize (G_ "hint: ")) port) -- cgit v1.2.3 From 544265acba89a41691c6be5b4af8e3c2237cd5c6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Apr 2019 17:17:38 +0200 Subject: colors: Add 'colorize-matches'. * guix/colors.scm (colorize-matches): New procedure. (color-rules): Rewrite in terms of 'colorize-matches'. --- guix/colors.scm | 55 ++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 34 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/colors.scm b/guix/colors.scm index b7d3f6d4ec..30ad231dfe 100644 --- a/guix/colors.scm +++ b/guix/colors.scm @@ -132,34 +132,47 @@ that subsequent output will not have any colors in effect." (not (getenv "NO_COLOR")) (isatty?* port))) -(define-syntax color-rules - (syntax-rules () - "Return a procedure that colorizes the string it is passed according to -the given rules. Each rule has the form: +(define (colorize-matches rules) + "Return a procedure that, when passed a string, returns that string +colorized according to RULES. RULES must be a list of tuples like: (REGEXP COLOR1 COLOR2 ...) where COLOR1 specifies how to colorize the first submatch of REGEXP, and so on." - ((_ (regexp colors ...) rest ...) - (let ((next (color-rules rest ...)) - (rx (make-regexp regexp))) - (lambda (str) - (if (string-index str #\nul) - str - (match (regexp-exec rx str) - (#f (next str)) + (lambda (str) + (if (string-index str #\nul) + str + (let loop ((rules rules)) + (match rules + (() + str) + (((regexp . colors) . rest) + (match (regexp-exec regexp str) + (#f (loop rest)) (m (let loop ((n 1) - (c (list (color colors) ...)) - (result '())) - (match c + (colors colors) + (result (list (match:prefix m)))) + (match colors (() - (string-concatenate-reverse result)) + (string-concatenate-reverse + (cons (match:suffix m) result))) ((first . tail) - (loop (+ n 1) tail + (loop (+ n 1) + tail (cons (colorize-string (match:substring m n) first) - result))))))))))) - ((_) - (lambda (str) - str)))) + result))))))))))))) + +(define-syntax color-rules + (syntax-rules () + "Return a procedure that colorizes the string it is passed according to +the given rules. Each rule has the form: + + (REGEXP COLOR1 COLOR2 ...) + +where COLOR1 specifies how to colorize the first submatch of REGEXP, and so +on." + ((_ (regexp colors ...) ...) + (colorize-matches `((,(make-regexp regexp) ,(color colors) ...) + ...))))) -- cgit v1.2.3 From 88e13c2587ab9a0f96bb63488c253fb14ac9ff60 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Thu, 11 Apr 2019 23:49:43 +0200 Subject: build-system/linux-module: Support module source versioning. * guix/build-system/linux-module.scm (make-linux-module-builder) [native-inputs]: Add linux. [arguments]<#:phases>[install]: Install "System.map" and "Module.symvers". * guix/build/linux-module-build-system.scm (configure): Delete procedure. (%standard-phases): Delete "configure" phase. --- guix/build-system/linux-module.scm | 11 ++++++++++- guix/build/linux-module-build-system.scm | 6 +----- 2 files changed, 11 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm index 3ed3351353..6084d22210 100644 --- a/guix/build-system/linux-module.scm +++ b/guix/build-system/linux-module.scm @@ -63,6 +63,9 @@ (package (inherit linux) (name (string-append (package-name linux) "-module-builder")) + (native-inputs + `(("linux" ,linux) + ,@(package-native-inputs linux))) (arguments (substitute-keyword-arguments (package-arguments linux) ((#:phases phases) @@ -72,11 +75,17 @@ (invoke "make" "modules_prepare"))) (delete 'strip) ; faster. (replace 'install - (lambda* (#:key outputs #:allow-other-keys) + (lambda* (#:key inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (out-lib-build (string-append out "/lib/modules/build"))) ; TODO: Only preserve the minimum, i.e. [Kbuild], Kconfig, scripts, include, ".config". (copy-recursively "." out-lib-build) + (let* ((linux (assoc-ref inputs "linux"))) + (install-file (string-append linux "/System.map") + out-lib-build) + (let ((source (string-append linux "/Module.symvers"))) + (if (file-exists? source) + (install-file source out-lib-build)))) #t))))))))) (define* (lower name diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm index a6664f1eca..01cb8cef6c 100644 --- a/guix/build/linux-module-build-system.scm +++ b/guix/build/linux-module-build-system.scm @@ -32,10 +32,6 @@ ;; ;; Code: -;; TODO: It might make sense to provide "Module.symvers" in the future. -(define* (configure #:key inputs #:allow-other-keys) - #t) - (define* (build #:key inputs make-flags #:allow-other-keys) (apply invoke "make" "-C" (string-append (assoc-ref inputs "linux-module-builder") @@ -64,7 +60,7 @@ (define %standard-phases (modify-phases gnu:%standard-phases - (replace 'configure configure) + (delete 'configure) (replace 'build build) (replace 'install install))) -- cgit v1.2.3 From 0b30a1a072de0dd288519bde6b401a3e906eff84 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Fri, 12 Apr 2019 00:43:36 +0200 Subject: build-system/linux-module: Configure module like the kernel. * guix/build/linux-module-build-system.scm (configure): New procedure. (%standard-phases): Add "configure" phase. --- guix/build/linux-module-build-system.scm | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm index 01cb8cef6c..cd76df2de7 100644 --- a/guix/build/linux-module-build-system.scm +++ b/guix/build/linux-module-build-system.scm @@ -32,6 +32,23 @@ ;; ;; Code: +;; Copied from make-linux-libre's "configure" phase. +(define* (configure #:key inputs target #:allow-other-keys) + (setenv "KCONFIG_NOTIMESTAMP" "1") + (setenv "KBUILD_BUILD_TIMESTAMP" (getenv "SOURCE_DATE_EPOCH")) + ;(let ((arch ,(system->linux-architecture + ; (or (%current-target-system) + ; (%current-system))))) + ; (setenv "ARCH" arch) + ; (format #t "`ARCH' set to `~a'~%" (getenv "ARCH"))) + (when target + (setenv "CROSS_COMPILE" (string-append target "-")) + (format #t "`CROSS_COMPILE' set to `~a'~%" + (getenv "CROSS_COMPILE"))) + ; TODO: (setenv "EXTRA_VERSION" ,extra-version) + ; TODO: kernel ".config". + #t) + (define* (build #:key inputs make-flags #:allow-other-keys) (apply invoke "make" "-C" (string-append (assoc-ref inputs "linux-module-builder") @@ -60,7 +77,7 @@ (define %standard-phases (modify-phases gnu:%standard-phases - (delete 'configure) + (replace 'configure configure) (replace 'build build) (replace 'install install))) -- cgit v1.2.3 From c1c5d68a94e219d0e56d5dc0e0d6ed9b08076a30 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 14 Apr 2019 19:48:19 +0200 Subject: colors: Add 'highlight'. * guix/colors.scm (%highlight-color): New variable. (highlight): New procedure. * guix/ui.scm (%highlight-argument)[highlight]: Remove. (%highlight-color): Remove. --- guix/colors.scm | 10 ++++++++++ guix/ui.scm | 11 ++--------- 2 files changed, 12 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/colors.scm b/guix/colors.scm index 30ad231dfe..7949cf5763 100644 --- a/guix/colors.scm +++ b/guix/colors.scm @@ -30,6 +30,7 @@ color? colorize-string + highlight color-rules color-output? isatty?*)) @@ -132,6 +133,15 @@ that subsequent output will not have any colors in effect." (not (getenv "NO_COLOR")) (isatty?* port))) +(define %highlight-color (color BOLD)) + +(define* (highlight str #:optional (port (current-output-port))) + "Return STR with extra ANSI color attributes to highlight it if PORT +supports it." + (if (color-output? port) + (colorize-string str %highlight-color) + str)) + (define (colorize-matches rules) "Return a procedure that, when passed a string, returns that string colorized according to RULES. RULES must be a list of tuples like: diff --git a/guix/ui.scm b/guix/ui.scm index 2481a1b78b..39b13fd4bc 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -155,16 +155,10 @@ is a trivial format string." (define* (%highlight-argument arg #:optional (port (guix-warning-port))) "Highlight ARG, a format string argument, if PORT supports colors." - (define highlight - (if (color-output? port) - (lambda (str) - (colorize-string str %highlight-color)) - identity)) - (cond ((string? arg) - (highlight arg)) + (highlight arg port)) ((symbol? arg) - (highlight (symbol->string arg))) + (highlight (symbol->string arg) port)) (else arg))) (define-syntax define-diagnostic @@ -220,7 +214,6 @@ messages." (define %info-color (color BOLD)) (define %error-color (color BOLD RED)) (define %hint-color (color BOLD CYAN)) -(define %highlight-color (color BOLD)) (define* (print-diagnostic-prefix prefix #:optional location #:key (colors (color))) -- cgit v1.2.3 From 3dae43a92975cb6a1055e928523122bc340272fd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 14 Apr 2019 19:49:38 +0200 Subject: ui: Highlight heading of generation lists. * guix/ui.scm (display-generation): Highlight the "Generation" heading. --- guix/ui.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 39b13fd4bc..92c845e944 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1564,7 +1564,7 @@ DURATION-RELATION with the current time." (define (display-generation profile number) "Display a one-line summary of generation NUMBER of PROFILE." (unless (zero? number) - (let ((header (format #f (G_ "Generation ~a\t~a") number + (let ((header (format #f (highlight (G_ "Generation ~a\t~a")) number (date->string (time-utc->date (generation-time profile number)) -- cgit v1.2.3 From 4aea820f0954fce4d076718072faf211f62f3f9d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 15 Apr 2019 16:57:12 +0200 Subject: guix build: Fix relative file name canonicalization for '--root'. Fixes . Reported by rendaw <7e9wc56emjakcm@s.rendaw.me>. * guix/scripts/build.scm (register-root): When ROOT is a relative file name, append the basename of ROOT, not ROOT itself. * tests/guix-build.sh: Add test. --- guix/scripts/build.scm | 2 +- tests/guix-build.sh | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 28864435df..fc0c0e2ad3 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -119,7 +119,7 @@ found. Return #f if no build log was found." (let* ((root (if (string-prefix? "/" root) root (string-append (canonicalize-path (dirname root)) - "/" root)))) + "/" (basename root))))) (catch 'system-error (lambda () (match paths diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 66bf6be8d0..d479296ef1 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -183,6 +183,13 @@ then false; else true; fi rm -f "$result" +# Check relative file name canonicalization: . +mkdir "$result" +guix build -r "$result/x" -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' +test -x "$result/x/bin/guile" +rm "$result/x" +rmdir "$result" + # Cross building. guix build coreutils --target=mips64el-linux-gnu --dry-run --no-substitutes -- cgit v1.2.3 From 3961edf2304bcff4c402a29868f8c559a03c0663 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 16 Apr 2019 10:26:46 +0200 Subject: store: Memoize 'built-in-builders' call directly in . The caching strategy introduced in 40cc850aebb497faed0a11d867d8fcee729023df was ineffective since we regularly start from an empty object cache. For example, "guix build inkscape -n" would make 241 'built-in-builders' RPCs. * guix/store.scm ()[built-in-builders]: New field. (open-connection): Adjust '%make-store-connection' call accordingly. (port->connection): Likewise. (built-in-builders): Rename to... (%built-in-builders): ... this. (built-in-builders): New procedure. * guix/download.scm (built-in-builders*): Remove 'mcached' call. --- guix/download.scm | 8 ++------ guix/store.scm | 49 ++++++++++++++++++++++++++++++++----------------- 2 files changed, 34 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index 8865777818..11984cf671 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2013, 2014, 2015 Andreas Enge ;;; Copyright © 2015 Federico Beffa ;;; Copyright © 2016 Alex Griffin @@ -415,11 +415,7 @@ (object->string %content-addressed-mirrors))) (define built-in-builders* - (let ((proc (store-lift built-in-builders))) - (lambda () - "Return, as a monadic value, the list of built-in builders supported by -the daemon; cache the return value." - (mcached (proc) built-in-builders)))) + (store-lift built-in-builders)) (define* (built-in-download file-name url #:key system hash-algo hash diff --git a/guix/store.scm b/guix/store.scm index fdd04f349d..9c195c335c 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -368,7 +368,9 @@ (ats-cache store-connection-add-to-store-cache) (atts-cache store-connection-add-text-to-store-cache) (object-cache store-connection-object-cache - (default vlist-null))) ;vhash + (default vlist-null)) ;vhash + (built-in-builders store-connection-built-in-builders + (default (delay '())))) ;promise (set-record-type-printer! (lambda (obj port) @@ -557,13 +559,17 @@ for this connection will be pinned. Return a server object." (write-int cpu-affinity port))) (when (>= (protocol-minor v) 11) (write-int (if reserve-space? 1 0) port)) - (let ((conn (%make-store-connection port - (protocol-major v) - (protocol-minor v) - output flush - (make-hash-table 100) - (make-hash-table 100) - vlist-null))) + (letrec* ((built-in-builders + (delay (%built-in-builders conn))) + (conn + (%make-store-connection port + (protocol-major v) + (protocol-minor v) + output flush + (make-hash-table 100) + (make-hash-table 100) + vlist-null + built-in-builders))) (let loop ((done? (process-stderr conn))) (or done? (process-stderr conn))) conn))))))))) @@ -578,13 +584,17 @@ already taken place on PORT and that we're just continuing on this established connection. Use with care." (let-values (((output flush) (buffering-output-port port (make-bytevector 8192)))) - (%make-store-connection port - (protocol-major version) - (protocol-minor version) - output flush - (make-hash-table 100) - (make-hash-table 100) - vlist-null))) + (define connection + (%make-store-connection port + (protocol-major version) + (protocol-minor version) + output flush + (make-hash-table 100) + (make-hash-table 100) + vlist-null + (delay (%built-in-builders connection)))) + + connection)) (define (store-connection-version store) "Return the protocol version of STORE as an integer." @@ -1371,13 +1381,13 @@ that there is no guarantee that the order of the resulting list matches the order of PATHS." substitutable-path-list)) -(define built-in-builders +(define %built-in-builders (let ((builders (operation (built-in-builders) "Return the built-in builders." string-list))) (lambda (store) "Return the names of the supported built-in derivation builders -supported by STORE." +supported by STORE. The result is memoized for STORE." ;; Check whether STORE's version supports this RPC and built-in ;; derivation builders in general, which appeared in Guix > 0.11.0. ;; Return the empty list if it doesn't. Note that this RPC does not @@ -1388,6 +1398,11 @@ supported by STORE." (builders store) '())))) +(define (built-in-builders store) + "Return the names of the supported built-in derivation builders +supported by STORE." + (force (store-connection-built-in-builders store))) + (define-operation (optimize-store) "Optimize the store by hard-linking identical files (\"deduplication\".) Return #t on success." -- cgit v1.2.3 From e856177597b5a7f1b75bb4083ad1e0b50323c82e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 16 Apr 2019 11:42:18 +0200 Subject: derivations: Reduce 'valid-path?' RPCs in 'derivation-prerequisites-to-build'. On a profile with 280 packages, this reduces the number of 'valid-paths?' RPCs made by 'guix package -nu' from 6K to 500. * guix/derivations.scm (derivation-prerequisites-to-build)[built?]: Memoize 'valid-path?' calls. --- guix/derivations.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index fb2fa177be..7a5c3bca94 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2016, 2017 Mathieu Lirzin ;;; ;;; This file is part of GNU Guix. @@ -344,7 +344,8 @@ OUTPUTS of DRV and not already available in STORE, recursively, and the list of required store paths that can be substituted. SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned by 'substitution-oracle'." (define built? - (cut valid-path? store <>)) + (mlambda (item) + (valid-path? store item))) (define input-built? (compose (cut any built? <>) derivation-input-output-paths)) -- cgit v1.2.3 From d1f7748a2e41f2ca320eca56b366933b8aa1123c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 16 Apr 2019 11:46:17 +0200 Subject: store: Add "add-data-to-store-cache" profiling component. * guix/store.scm (add-data-to-store): Define 'lookup' and use it instead of 'hash-ref'. --- guix/store.scm | 42 ++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 40 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 9c195c335c..1b485ab5fa 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -996,14 +996,52 @@ string). Raise an error if no such path exists." (operation (add-text-to-store (string name) (bytevector text) (string-list references)) #f - store-path))) + store-path)) + (lookup (if (profiled? "add-data-to-store-cache") + (let ((lookups 0) + (hits 0) + (drv 0) + (scheme 0)) + (define (show-stats) + (define (% n) + (if (zero? lookups) + 100. + (* 100. (/ n lookups)))) + + (format (current-error-port) " +'add-data-to-store' cache: + lookups: ~5@a + hits: ~5@a (~,1f%) + .drv files: ~5@a (~,1f%) + Scheme files: ~5@a (~,1f%)~%" + lookups hits (% hits) + drv (% drv) + scheme (% scheme))) + + (register-profiling-hook! "add-data-to-store-cache" + show-stats) + (lambda (cache args) + (let ((result (hash-ref cache args))) + (set! lookups (+ 1 lookups)) + (when result + (set! hits (+ 1 hits))) + (match args + ((_ name _) + (cond ((string-suffix? ".drv" name) + (set! drv (+ drv 1))) + ((string-suffix? "-builder" name) + (set! scheme (+ scheme 1))) + ((string-suffix? ".scm" name) + (set! scheme (+ scheme 1)))))) + result))) + hash-ref))) (lambda* (server name bytes #:optional (references '())) "Add BYTES under file NAME in the store, and return its store path. REFERENCES is the list of store paths referred to by the resulting store path." (let* ((args `(,bytes ,name ,references)) (cache (store-connection-add-text-to-store-cache server))) - (or (hash-ref cache args) + (or (lookup cache args) (let ((path (add-text-to-store server name bytes references))) (hash-set! cache args path) path)))))) -- cgit v1.2.3 From ab77b69eca6959c9ce946ca18d218aab8ade1cc1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 16 Apr 2019 23:23:02 +0200 Subject: self: Remove unused variable. This variable is unused since commit 45779fa676419de8838cb26b6c7a24678a2be1cd. * guix/self.scm (%dependency-variables): Remove. * build-aux/build-self.scm (%dependency-variables): Remove. --- build-aux/build-self.scm | 4 ---- guix/self.scm | 4 ---- 2 files changed, 8 deletions(-) (limited to 'guix') diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index a8b05eb0ff..9619e0e5b2 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -54,10 +54,6 @@ ;;; available at this point. ;;; -(define %dependency-variables - ;; (guix config) variables corresponding to dependencies. - '(%libgcrypt %libz %xz %gzip %bzip2)) - (define %persona-variables ;; (guix config) variables that define Guix's persona. '(%guix-package-name diff --git a/guix/self.scm b/guix/self.scm index 7ba2764eb9..de921e6d9c 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -753,10 +753,6 @@ Info manual." ;;; Generating (guix config). ;;; -(define %dependency-variables - ;; (guix config) variables corresponding to dependencies. - '(%libz %xz %gzip %bzip2)) - (define %persona-variables ;; (guix config) variables that define Guix's persona. '(%guix-package-name -- cgit v1.2.3 From f2d86ed0b3e371ee95cbc0098b7b2ccb757bc948 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 16 Apr 2019 23:32:39 +0200 Subject: build: No longer substitute 'LIBGCRYPT'. This had become useless since ca719424455465fca4b872c371daf2a46de88b33. * configure.ac (LIBGCRYPT): Remove. * guix/config.scm.in (%libgcrypt): Remove. --- configure.ac | 8 -------- guix/config.scm.in | 4 ---- 2 files changed, 12 deletions(-) (limited to 'guix') diff --git a/configure.ac b/configure.ac index 5d70de4beb..7e7ae02730 100644 --- a/configure.ac +++ b/configure.ac @@ -202,7 +202,6 @@ else AC_MSG_RESULT([not found]) fi -LIBGCRYPT="libgcrypt" LIBGCRYPT_LIBDIR="no" LIBGCRYPT_PREFIX="no" @@ -212,7 +211,6 @@ AC_ARG_WITH([libgcrypt-prefix], yes|no) ;; *) - LIBGCRYPT="$withval/lib/libgcrypt" LIBGCRYPT_PREFIX="$withval" LIBGCRYPT_LIBDIR="$withval/lib" ;; @@ -223,11 +221,9 @@ AC_ARG_WITH([libgcrypt-libdir], [search for GNU libgcrypt's shared library in DIR])], [case "$withval" in yes|no) - LIBGCRYPT="libgcrypt" LIBGCRYPT_LIBDIR="no" ;; *) - LIBGCRYPT="$withval/libgcrypt" LIBGCRYPT_LIBDIR="$withval" ;; esac]) @@ -240,10 +236,6 @@ case "x$LIBGCRYPT_PREFIX$LIBGCRYPT_LIBDIR" in ;; esac -dnl Library name suitable for `dynamic-link'. -AC_MSG_CHECKING([for libgcrypt shared library name]) -AC_MSG_RESULT([$LIBGCRYPT]) -AC_SUBST([LIBGCRYPT]) AC_SUBST([LIBGCRYPT_PREFIX]) AC_SUBST([LIBGCRYPT_LIBDIR]) diff --git a/guix/config.scm.in b/guix/config.scm.in index d2ec9921c6..247b15ed81 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -33,7 +33,6 @@ %config-directory %system - %libgcrypt %libz %gzip %bzip2 @@ -88,9 +87,6 @@ (define %system "@guix_system@") -(define %libgcrypt - "@LIBGCRYPT@") - (define %libz "@LIBZ@") -- cgit v1.2.3 From 72f749dcb83dbda9f98e28fa3622cc1d3db6275a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 17 Apr 2019 13:56:40 +0200 Subject: pull: '--url', '--commit', and '--branch' apply to the 'guix' channel. Suggested by pkill9 . * guix/scripts/pull.scm (channel-list): Apply REF and URL to the 'guix' channel. * doc/guix.texi (Invoking guix pull): Adjust accordingly. --- doc/guix.texi | 5 +++-- guix/channels.scm | 1 + guix/scripts/pull.scm | 24 +++++++++++------------- 3 files changed, 15 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index f8e7436cf1..6b713aaf9c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3646,8 +3646,9 @@ but it supports the following options: @item --url=@var{url} @itemx --commit=@var{commit} @itemx --branch=@var{branch} -Download code from the specified @var{url}, at the given @var{commit} (a valid -Git commit ID represented as a hexadecimal string), or @var{branch}. +Download code for the @code{guix} channel from the specified @var{url}, at the +given @var{commit} (a valid Git commit ID represented as a hexadecimal +string), or @var{branch}. @cindex @file{channels.scm}, configuration file @cindex configuration file for channels diff --git a/guix/channels.scm b/guix/channels.scm index 9658cf9393..e93879e1b4 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -52,6 +52,7 @@ channel-location %default-channels + guix-channel? channel-instance? channel-instance-channel diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 55137fce8f..71e13686c0 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -502,24 +502,22 @@ Use '~/.config/guix/channels.scm' instead.")) (url (or (assoc-ref opts 'repository-url) (environment-variable)))) (if (or ref url) - (match channels - ((one) - ;; When there's only one channel, apply '--url', '--commit', and - ;; '--branch' to this specific channel. - (let ((url (or url (channel-url one)))) - (list (match ref + (match (find guix-channel? channels) + ((? channel? guix) + ;; Apply '--url', '--commit', and '--branch' to the 'guix' channel. + (let ((url (or url (channel-url guix)))) + (cons (match ref (('commit . commit) - (channel (inherit one) + (channel (inherit guix) (url url) (commit commit) (branch #f))) (('branch . branch) - (channel (inherit one) + (channel (inherit guix) (url url) (commit #f) (branch branch))) (#f - (channel (inherit one) (url url))))))) - (_ - ;; Otherwise bail out. - (leave - (G_ "'--url', '--commit', and '--branch' are not applicable~%")))) + (channel (inherit guix) (url url)))) + (remove guix-channel? channels)))) + (#f ;no 'guix' channel, failure will ensue + channels)) channels))) -- cgit v1.2.3 From 702c3c7dab87df674c3d6abc138805895b5d1d32 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 18 Apr 2019 10:19:54 +0200 Subject: lint: 'check-github-url' uses our own 'open-connection-for-uri'. Fixes . Reported by Efraim Flashner . Previously 'check-github-url' would let Guile 2.2's (web client) module take care of opening the connection. Consequently, it wouldn't use the TLS priority strings that we use in (guix build download), 'open-connection-for-uri'. In particular, it would not disable TLSv1.3, which would trigger for github.com. * guix/scripts/lint.scm (check-github-url): Add #:timeout parameter. [follow-redirect]: Change parameter name to 'url' and pass it to 'string->uri'. Call 'guix:open-connection-for-uri' to open the connection and pass it to 'http-head' via #:port. --- guix/scripts/lint.scm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index ddad5b7fd0..dc338a1d7b 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -45,7 +45,6 @@ #:use-module (guix cve) #:use-module (gnu packages) #:use-module (ice-9 match) - #:use-module (ice-9 receive) #:use-module (ice-9 regex) #:use-module (ice-9 format) #:use-module (web client) @@ -796,10 +795,13 @@ descriptions maintained upstream." (let ((uris (origin-uris origin))) (for-each check-mirror-uri uris))))) -(define (check-github-url package) +(define* (check-github-url package #:key (timeout 3)) "Check whether PACKAGE uses source URLs that redirect to GitHub." - (define (follow-redirect uri) - (receive (response body) (http-head uri) + (define (follow-redirect url) + (let* ((uri (string->uri url)) + (port (guix:open-connection-for-uri uri #:timeout timeout)) + (response (http-head uri #:port port))) + (close-port port) (case (response-code response) ((301 302) (uri->string (assoc-ref (response-headers response) 'location))) -- cgit v1.2.3 From 3fdb9a375f1cee7dd302349a9527437df20b3f61 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 24 Mar 2019 21:23:45 +0000 Subject: guile-build-system: Support building in parallel. * guix/build/guile-build-system.scm (build): Use invoke-each, instead of for-each, to use multiple cores if available. (invoke-each, report-build-process): New procedures. --- guix/build/guile-build-system.scm | 98 ++++++++++++++++++++++++++++++++------- 1 file changed, 80 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/build/guile-build-system.scm b/guix/build/guile-build-system.scm index 0bed049436..31f0d3d6f4 100644 --- a/guix/build/guile-build-system.scm +++ b/guix/build/guile-build-system.scm @@ -65,6 +65,62 @@ Return #false if it cannot be determined." (setenv "GUIX_LOCPATH" (string-append locales "/lib/locale")) #t))) +(define* (invoke-each commands + #:key (max-processes (current-processor-count)) + report-progress) + "Run each command in COMMANDS in a separate process, using up to +MAX-PROCESSES processes in parallel. Call REPORT-PROGRESS at each step. +Raise an error if one of the processes exit with non-zero." + (define total + (length commands)) + + (define (wait-for-one-process) + (match (waitpid WAIT_ANY) + ((_ . status) + (unless (zero? (status:exit-val status)) + (error "process failed" status))))) + + (define (fork-and-run-command command) + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (apply execlp command)) + (lambda () + (primitive-exit 127)))) + (pid + #t))) + + (let loop ((commands commands) + (running 0) + (completed 0)) + (match commands + (() + (or (zero? running) + (let ((running (- running 1)) + (completed (+ completed 1))) + (wait-for-one-process) + (report-progress total completed) + (loop commands running completed)))) + ((command . rest) + (if (< running max-processes) + (let ((running (+ 1 running))) + (fork-and-run-command command) + (loop rest running completed)) + (let ((running (- running 1)) + (completed (+ completed 1))) + (wait-for-one-process) + (report-progress total completed) + (loop commands running completed))))))) + +(define* (report-build-progress total completed + #:optional (log-port (current-error-port))) + "Report that COMPLETED out of TOTAL files have been completed." + (format log-port "compiling...\t~5,1f% of ~d files~%" ;FIXME: i18n + (* 100. (/ completed total)) total) + (force-output log-port)) + (define* (build #:key outputs inputs native-inputs (source-directory ".") (compile-flags '()) @@ -101,24 +157,30 @@ Return #false if it cannot be determined." (match (getenv "GUILE_LOAD_COMPILED_PATH") (#f "") (path (string-append ":" path))))) - (for-each (lambda (file) - (let* ((go (string-append go-dir - (file-sans-extension file) - ".go"))) - ;; Install source module. - (install-file (string-append source-directory "/" file) - (string-append module-dir - "/" (dirname file))) - - ;; Install and compile module. - (apply invoke guild "compile" "-L" source-directory - "-o" go - (string-append source-directory "/" file) - flags))) - - ;; Arrange to strip SOURCE-DIRECTORY from file names. - (with-directory-excursion source-directory - (find-files "." scheme-file-regexp))) + + (let ((source-files + (with-directory-excursion source-directory + (find-files "." scheme-file-regexp)))) + (invoke-each + (map (lambda (file) + (cons* guild + "guild" "compile" + "-L" source-directory + "-o" (string-append go-dir + (file-sans-extension file) + ".go") + (string-append source-directory "/" file) + flags)) + source-files) + #:max-processes (parallel-job-count) + #:report-progress report-build-progress) + + (for-each + (lambda (file) + (install-file (string-append source-directory "/" file) + (string-append module-dir + "/" (dirname file)))) + source-files)) #t)) (define* (install-documentation #:key outputs -- cgit v1.2.3 From ea261dea0c581771b4cf297e983f7addc6807051 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 19 Apr 2019 15:18:20 +0200 Subject: guix build: Accept multiple '-s' options. * guix/scripts/build.scm (%default-options): Remove 'system'. (%options) <--system>: Keep previous occurrences of 'system in RESULT. (options->derivations)[system]: Remove. [systems, things-to-build]: New variables. [compute-derivation]: New procedure. Iterate on all of SYSTEMS to compute the derivations of THINGS-TO-BUILD. * tests/guix-build.sh: Add test for one and multiple '-s' flags. * doc/guix.texi (Additional Build Options): Document this behavior. --- doc/guix.texi | 4 +- guix/scripts/build.scm | 107 +++++++++++++++++++++++++++---------------------- tests/guix-build.sh | 7 ++++ 3 files changed, 70 insertions(+), 48 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 6b713aaf9c..8c7522f286 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -8030,7 +8030,9 @@ The following derivations will be built: @item --system=@var{system} @itemx -s @var{system} Attempt to build for @var{system}---e.g., @code{i686-linux}---instead of -the system type of the build host. +the system type of the build host. The @command{guix build} command allows +you to repeat this option several times, in which case it builds for all the +specified systems; other commands ignore extraneous @option{-s} options. @quotation Note The @code{--system} flag is for @emph{native} compilation and must not diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index fc0c0e2ad3..ba143ad16b 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -635,8 +635,7 @@ options handled by 'set-build-options-from-command-line', and listed in (define %default-options ;; Alist of default option values. - `((system . ,(%current-system)) - (build-mode . ,(build-mode normal)) + `((build-mode . ,(build-mode normal)) (graft? . #t) (substitutes? . #t) (build-hook? . #t) @@ -729,8 +728,7 @@ must be one of 'package', 'all', or 'transitive'~%") rest))) (option '(#\s "system") #t #f (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) + (alist-cons 'system arg result))) (option '("target") #t #f (lambda (opt name arg result) (alist-cons 'target arg @@ -811,56 +809,71 @@ build." (cut package-cross-derivation <> <> triplet <>)))) (define src (assoc-ref opts 'source)) - (define system (assoc-ref opts 'system)) (define graft? (assoc-ref opts 'graft?)) + (define systems + (match (filter-map (match-lambda + (('system . system) system) + (_ #f)) + opts) + (() (list (%current-system))) + (systems systems))) + + (define things-to-build + (map (cut transform store <>) + (options->things-to-build opts))) + + (define (compute-derivation obj system) + ;; Compute the derivation of OBJ for SYSTEM. + (match obj + ((? package? p) + (let ((p (or (and graft? (package-replacement p)) p))) + (match src + (#f + (list (package->derivation store p system))) + (#t + (match (package-source p) + (#f + (format (current-error-port) + (G_ "~a: warning: \ +package '~a' has no source~%") + (location->string (package-location p)) + (package-name p)) + '()) + (s + (list (package-source-derivation store s))))) + (proc + (map (cut package-source-derivation store <>) + (proc p)))))) + ((? derivation? drv) + (list drv)) + ((? procedure? proc) + (list (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (proc)) + #:system system))) + ((? file-like? obj) + (list (run-with-store store + (lower-object obj system + #:target (assoc-ref opts 'target)) + #:system system))) + ((? gexp? gexp) + (list (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (gexp->derivation "gexp" gexp + #:system system)) + #:system system))))) ;; We may get 'unbound-variable' errors while evaluating the 'inputs' fields ;; of user packages. Since 'guix build' is the primary tool for people ;; testing new packages, report such errors gracefully. (with-unbound-variable-handling (parameterize ((%graft? graft?)) - (append-map (match-lambda - ((? package? p) - (let ((p (or (and graft? (package-replacement p)) p))) - (match src - (#f - (list (package->derivation store p system))) - (#t - (match (package-source p) - (#f - (format (current-error-port) - (G_ "~a: warning: \ -package '~a' has no source~%") - (location->string (package-location p)) - (package-name p)) - '()) - (s - (list (package-source-derivation store s))))) - (proc - (map (cut package-source-derivation store <>) - (proc p)))))) - ((? derivation? drv) - (list drv)) - ((? procedure? proc) - (list (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (proc)) - #:system system))) - ((? file-like? obj) - (list (run-with-store store - (lower-object obj system - #:target (assoc-ref opts 'target)) - #:system system))) - ((? gexp? gexp) - (list (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (gexp->derivation "gexp" gexp - #:system system)) - #:system system)))) - (map (cut transform store <>) - (options->things-to-build opts)))))) + (append-map (lambda (system) + (append-map (cut compute-derivation <> system) + things-to-build)) + systems)))) (define (show-build-log store file urls) "Show the build log for FILE, falling back to remote logs from URLS if diff --git a/tests/guix-build.sh b/tests/guix-build.sh index d479296ef1..63a9fe68da 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -44,6 +44,13 @@ guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'; \ then exit 1; fi ) +# Passing one '-s' flag. +test `guix build sed -s x86_64-linux -d | wc -l` = 1 + +# Passing multiple '-s' flags. +all_systems="-s x86_64-linux -s i686-linux -s armhf-linux -s aarch64-linux" +test `guix build sed $all_systems -d | sort -u | wc -l` = 4 + # Check --sources option with its arguments module_dir="t-guix-build-$$" mkdir "$module_dir" -- cgit v1.2.3 From c5265a095172b213ba6fbdf618d6779359ca56b2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 21 Apr 2019 21:26:06 +0200 Subject: pull: Add '--news'. Suggested by Tobias Geerinckx-Rice . * guix/scripts/pull.scm (%options, show-help): Add '--news'. (display-profile-news): Add #:current-is-newer? and #:concise?. Honor them. (build-and-install): Pass #:concise? #t. (display-new/upgraded-packages)[concise/max-item-count]: New variable. Add call to 'display-hint'. (process-query): Add clause for 'display-news'. * doc/guix.texi (Invoking guix pull): Add '--news'. --- doc/guix.texi | 8 ++++++ guix/scripts/pull.scm | 76 ++++++++++++++++++++++++++++++++++++--------------- 2 files changed, 62 insertions(+), 22 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 8c7522f286..785329add8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3663,6 +3663,14 @@ Read the list of channels from @var{file} instead of evaluates to a list of channel objects. @xref{Channels}, for more information. +@item --news +@itemx -N +Display the list of packages added or upgraded since the previous generation. + +This is the same information as displayed upon @command{guix pull} completion, +but without ellipses; it is also similar to the output of @command{guix pull +-l} for the last generation (see below). + @item --list-generations[=@var{pattern}] @itemx -l [@var{pattern}] List all the generations of @file{~/.config/guix/current} or, if @var{pattern} diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 71e13686c0..04e83f970f 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -86,6 +86,8 @@ Download and deploy the latest version of Guix.\n")) (display (G_ " --branch=BRANCH download the tip of the specified BRANCH")) (display (G_ " + -N, --news display news compared to the previous generation")) + (display (G_ " -l, --list-generations[=PATTERN] list generations matching PATTERN")) (display (G_ " @@ -117,6 +119,9 @@ Download and deploy the latest version of Guix.\n")) (lambda (opt name arg result) (cons `(query list-generations ,(or arg "")) result))) + (option '(#\N "news") #f #f + (lambda (opt name arg result) + (cons '(query display-news) result))) (option '("url") #t #f (lambda (opt name arg result) (alist-cons 'repository-url arg @@ -162,25 +167,33 @@ Download and deploy the latest version of Guix.\n")) (define indirect-root-added (store-lift add-indirect-root)) -(define (display-profile-news profile) - "Display what's up in PROFILE--new packages, and all that." +(define* (display-profile-news profile #:key concise? + current-is-newer?) + "Display what's up in PROFILE--new packages, and all that. If +CURRENT-IS-NEWER? is true, assume that the current process represents the +newest generation of PROFILE.x" (match (memv (generation-number profile) (reverse (profile-generations profile))) ((current previous _ ...) - (newline) - (let ((old (fold-available-packages - (lambda* (name version result - #:key supported? deprecated? - #:allow-other-keys) - (if (and supported? (not deprecated?)) - (alist-cons name version result) - result)) - '())) - (new (profile-package-alist - (generation-file-name profile current)))) - (display-new/upgraded-packages old new - #:concise? #t - #:heading (G_ "New in this revision:\n")))) + (let ((these (fold-available-packages + (lambda* (name version result + #:key supported? deprecated? + #:allow-other-keys) + (if (and supported? (not deprecated?)) + (alist-cons name version result) + result)) + '())) + (those (profile-package-alist + (generation-file-name profile + (if current-is-newer? + previous + current))))) + (let ((old (if current-is-newer? those these)) + (new (if current-is-newer? these those))) + (display-new/upgraded-packages old new + #:concise? concise? + #:heading + (G_ "New in this revision:\n"))))) (_ #t))) (define* (build-and-install instances profile @@ -196,7 +209,8 @@ true, display what would be built without actually building it." #:hooks %channel-profile-hooks #:dry-run? dry-run?) (munless dry-run? - (return (display-profile-news profile)) + (return (newline)) + (return (display-profile-news profile #:concise? #t)) (match (which "guix") (#f (return #f)) (str @@ -394,9 +408,13 @@ display long package lists that would fill the user's screen." column) 4)) + (define concise/max-item-count + ;; Maximum number of items to display when CONCISE? is true. + 12) + (define list->enumeration (if concise? - (lambda* (lst #:optional (max 12)) + (lambda* (lst #:optional (max concise/max-item-count)) (if (> (length lst) max) (string-append (string-join (take lst max) ", ") ", " (ellipsis)) @@ -404,10 +422,13 @@ display long package lists that would fill the user's screen." (cut string-join <> ", "))) (let-values (((new upgraded) (new/upgraded-packages alist1 alist2))) + (define new-count (length new)) + (define upgraded-count (length upgraded)) + (unless (and (null? new) (null? upgraded)) (display heading)) - (match (length new) + (match new-count (0 #t) (count (format #t (N_ " ~h new package: ~a~%" @@ -415,14 +436,20 @@ display long package lists that would fill the user's screen." count (pretty (list->enumeration (sort (map first new) stringenumeration (sort upgraded string new-count concise/max-item-count) + (> upgraded-count concise/max-item-count))) + (display-hint (G_ "Run @command{guix pull --news} to view the complete +list of package changes."))))) (define (display-profile-content-diff profile gen1 gen2) "Display the changes in PROFILE GEN2 compared to generation GEN1." @@ -462,7 +489,12 @@ display long package lists that would fill the user's screen." (() (exit 1)) ((numbers ...) - (list-generations profile numbers))))))))) + (list-generations profile numbers))))))) + (('display-news) + ;; Display profile news, with the understanding that this process + ;; represents the newest generation. + (display-profile-news profile + #:current-is-newer? #t)))) (define (channel-list opts) "Return the list of channels to use. If OPTS specify a channel file, -- cgit v1.2.3 From a06a95baffc2005ad1a64c4c3f82fc328e0d0009 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 22 Apr 2019 11:50:49 +0200 Subject: pull: Create profile after the store connection has been opened. Fixes . Reported by Florian Pelz . Previously, we'd call 'ensure-default-profile' before the connection to the daemon has been opened. On the first connection, the daemon ensures that /var/guix/profiles/per-user is world-writable. Since we were calling 'ensure-default-profile' before that, /var/guix/profiles/per-user was typically non-writable (555 and root-owned), and thus 'guix pull' would error out. * guix/scripts/pull.scm (guix-pull): Call 'ensure-default-profile' within 'with-store'. --- guix/scripts/pull.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 04e83f970f..3929cd402e 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -561,11 +561,11 @@ Use '~/.config/guix/channels.scm' instead.")) (cache (string-append (cache-directory) "/pull")) (channels (channel-list opts)) (profile (or (assoc-ref opts 'profile) %current-profile))) - (ensure-default-profile) (cond ((assoc-ref opts 'query) (process-query opts profile)) (else (with-store store + (ensure-default-profile) (with-status-verbosity (assoc-ref opts 'verbosity) (parameterize ((%current-system (assoc-ref opts 'system)) (%graft? (assoc-ref opts 'graft?)) -- cgit v1.2.3 From af41e504cf0e4039615015cc49baa947e1715c47 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 23 Apr 2019 23:39:07 +0200 Subject: guix system: Compute 'bootcfg' only for 'init' and 'reconfigure'. Previously, 'guix system vm' would start by computing the bootcfg derivation, which itself depended on an incorrect OS derivation (for the original OS instead of the one passed through 'virtualized-operating-system'.) That added overhead and would force the user's config file to define a root file system, for example, even though it makes no sense in the case of a VM. * guix/scripts/system.scm (perform-action)[bootcfg]: Limit to the 'init' and 'reconfigure' actions. --- guix/scripts/system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 78aa6cf644..3c3d6cbd5f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -855,7 +855,7 @@ static checks." (bootloader-configuration-bootloader (operating-system-bootloader os))) (define bootcfg - (and (not (eq? 'container action)) + (and (memq action '(init reconfigure)) (operating-system-bootcfg os menu-entries))) (define bootloader-script -- cgit v1.2.3 From 17503ea8a26ce1e13b8c682a3b0d6280c2e06234 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 24 Apr 2019 15:55:40 +0200 Subject: self: Install 'guix.zh_CN.info'. Reported by Julien Lepiller. * guix/self.scm (info-manual): Adjust file name regexp so that it matches *.zh_CN.texi. --- guix/self.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index de921e6d9c..2a10d1d25f 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -350,7 +350,7 @@ DOMAIN, a gettext domain." (basename texi ".texi") ".info"))) (cons "guix.texi" - (find-files "." "^guix\\.[a-z]{2}\\.texi$"))) + (find-files "." "^guix\\.[a-z]{2}(_[A-Z]{2})?\\.texi$"))) ;; Compress Info files. (setenv "PATH" -- cgit v1.2.3 From 52beae7b8a33717259895add631b8ae71e958e0e Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Wed, 24 Apr 2019 19:31:39 +0200 Subject: gnu, guix: Yearly ritual purging of the filesystems. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/android.scm (android-ext4-utils)[synopsis]: Fix ‘file system’ spelling. * gnu/packages/disk.scm (rmlint)[synopsis, description]: Likewise. * gnu/packages/golang.scm (go-github-com-kr-fs)[synopsis, description]: Likewise & edit for grammar. * gnu/packages/ipfs.scm (gx, go-ipfs)[description]: Likewise. * /gnu/packages/java.scm (java-commons-vfs)[synopsis]: Likewise. * gnu/packages/linux.scm (fuseiso)[description]: Likewise. (genext2fs)[synopsis, description]: Likewise. * gnu/packages/package-management.scm (libostree)[description]: Likewise. * gnu/packages/python-xyz.scm (python-requests-file)[description]: Likewise & mark up. * gnu/packages/rails.scm (ruby-with-advisory-lock)[description]: Likewise. * gnu/packages/ruby.scm (ruby-rerun)[description]: Likewise. * guix/build/go-build-system.scm (setup-go-environment): Likewise. * guix/store/deduplication.scm (get-temp-link): Likewise. --- gnu/packages/android.scm | 2 +- gnu/packages/disk.scm | 4 ++-- gnu/packages/golang.scm | 5 +++-- gnu/packages/ipfs.scm | 4 ++-- gnu/packages/java.scm | 2 +- gnu/packages/linux.scm | 10 +++++----- gnu/packages/package-management.scm | 4 ++-- gnu/packages/python-xyz.scm | 2 +- gnu/packages/rails.scm | 2 +- gnu/packages/ruby.scm | 2 +- guix/build/go-build-system.scm | 4 ++-- guix/store/deduplication.scm | 4 ++-- 12 files changed, 23 insertions(+), 22 deletions(-) (limited to 'guix') diff --git a/gnu/packages/android.scm b/gnu/packages/android.scm index 80eaab3e5c..7d5de08be9 100644 --- a/gnu/packages/android.scm +++ b/gnu/packages/android.scm @@ -538,7 +538,7 @@ that is safe to use for user space. It also includes (native-inputs `(("android-core" ,(android-platform-system-core version)))) (home-page "https://developer.android.com/") - (synopsis "Android ext4 filesystem utils") + (synopsis "Android ext4 file system utilities") (description "@code{android-ext4-utils} is a library in common use by the Android core.") (license license:asl2.0))) diff --git a/gnu/packages/disk.scm b/gnu/packages/disk.scm index e52c4614c1..c8d2af88ca 100644 --- a/gnu/packages/disk.scm +++ b/gnu/packages/disk.scm @@ -808,9 +808,9 @@ LVM D-Bus API).") ("json-glib" ,json-glib) ("libblkid" ,util-linux))) (home-page "https://rmlint.rtfd.org") - (synopsis "Remove duplicates and other lint from the filesystem") + (synopsis "Remove duplicates and other lint from the file system") (description "@command{rmlint} finds space waste and other broken things -on your filesystem and offers to remove it. @command{rmlint} can find: +on your file system and offers to remove it. @command{rmlint} can find: @itemize @item duplicate files and duplicate directories, diff --git a/gnu/packages/golang.scm b/gnu/packages/golang.scm index 0b44bd3d02..5caf7a89f8 100644 --- a/gnu/packages/golang.scm +++ b/gnu/packages/golang.scm @@ -3168,8 +3168,9 @@ have super fancy logs.") (arguments '(#:import-path "github.com/kr/fs")) (home-page "https://github.com/kr/fs") - (synopsis "Filesystem-related functions for Go") - (description "Package fs provides filesystem-related functions.") + (synopsis "File-system-related functions for Go") + (description + "The fs package provides file-system-related Go functions.") (license license:bsd-3)))) (define-public go-github-com-direnv-go-dotenv diff --git a/gnu/packages/ipfs.scm b/gnu/packages/ipfs.scm index 6b8afd5f53..4f61f2ba66 100644 --- a/gnu/packages/ipfs.scm +++ b/gnu/packages/ipfs.scm @@ -152,7 +152,7 @@ that are shared between @command{go-ipfs/commands} and its rewrite (home-page "https://github.com/whyrusleeping/gx") (synopsis "Package management tool using IPFS") (description "@command{gx} is a packaging tool built around the -distributed, content addressed filesystem IPFS. It aims to be flexible, +distributed, content addressed file system IPFS. It aims to be flexible, powerful and simple.") (license license:expat))) @@ -244,7 +244,7 @@ written in Go.") #t)))))) (home-page "https://ipfs.io") (synopsis "Go implementation of IPFS, a peer-to-peer hypermedia protocol") - (description "IPFS is a global, versioned, peer-to-peer filesystem. It + (description "IPFS is a global, versioned, peer-to-peer file system. It combines good ideas from Git, BitTorrent, Kademlia, SFS, and the Web. It is like a single bittorrent swarm, exchanging git objects. IPFS provides an interface as simple as the HTTP web, but with permanence built in. You can diff --git a/gnu/packages/java.scm b/gnu/packages/java.scm index a47a1a008c..bcd3f98ce0 100644 --- a/gnu/packages/java.scm +++ b/gnu/packages/java.scm @@ -10296,7 +10296,7 @@ authentication, HTTP state management, and HTTP connection management.") ("java-commons-net" ,java-commons-net) ("java-jsch" ,java-jsch))) (home-page "http://commons.apache.org/proper/commons-vfs/") - (synopsis "Java filesystem library") + (synopsis "Java file system library") (description "Commons VFS provides a single API for accessing various different file systems. It presents a uniform view of the files from various different sources, such as the files on local disk, on an HTTP server, or diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index f3ed832417..62a98ec739 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -3361,7 +3361,7 @@ write access to exFAT devices.") (home-page "https://sourceforge.net/projects/fuseiso/") (synopsis "Mount ISO file system images") (description - "FuseISO is a FUSE module to mount ISO filesystem images (.iso, .nrg, + "FuseISO is a FUSE module to mount ISO file system images (.iso, .nrg, .bin, .mdf and .img files). It supports plain ISO9660 Level 1 and 2, Rock Ridge, Joliet, and zisofs.") (license license:gpl2))) @@ -3694,7 +3694,7 @@ from userspace.") ;; If users install ntfs-3g, they probably want to make it the ;; default driver as well, so we opt for sensible defaults and link ;; mount.ntfs to mount.ntfs-3g. (libmount tries to run mount.ntfs to - ;; mount NTFS filesystems.) + ;; mount NTFS file systems.) (add-after 'install 'install-link (lambda* (#:key outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) @@ -5240,9 +5240,9 @@ file systems.") `(("autoconf" ,autoconf) ("automake" ,automake))) (home-page "https://github.com/jeremie-koenig/genext2fs") - (synopsis "Generate ext2 filesystem as a normal user") - (description "This package provides a program to general an ext2 -filesystem as a normal (non-root) user. It does not require you to mount + (synopsis "Generate ext2 file system as a normal user") + (description "This package provides a program to generate an ext2 +file system as a normal (non-root) user. It does not require you to mount the image file to copy files on it, nor does it require that you become the superuser to make device nodes.") (license license:gpl2))) diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm index 6708a761eb..1556e103d5 100644 --- a/gnu/packages/package-management.scm +++ b/gnu/packages/package-management.scm @@ -1000,8 +1000,8 @@ for packaging and deployment of cross-compiled Windows applications.") (description "@code{libostree} is both a shared library and suite of command line tools that combines a \"git-like\" model for committing and downloading -bootable filesystem trees, along with a layer for deploying them and managing -the bootloader configuration.") +bootable file system trees, along with a layer for deploying them and managing +the boot loader configuration.") (license license:lgpl2.0+))) (define-public flatpak diff --git a/gnu/packages/python-xyz.scm b/gnu/packages/python-xyz.scm index 669d465e27..c7d7ff932b 100644 --- a/gnu/packages/python-xyz.scm +++ b/gnu/packages/python-xyz.scm @@ -14423,7 +14423,7 @@ introspection.") (synopsis "File transport adapter for Requests") (description "Requests-File is a transport adapter for use with the Requests Python -library to allow local filesystem access via file:// URLs.") +library to allow local file system access via @code{file://} URLs.") (license license:asl2.0))) (define-public python2-requests-file diff --git a/gnu/packages/rails.scm b/gnu/packages/rails.scm index e623f9b8c4..86ce1514f0 100644 --- a/gnu/packages/rails.scm +++ b/gnu/packages/rails.scm @@ -602,7 +602,7 @@ can also be launched manually in any page.") (synopsis "Advisory locking for ActiveRecord") (description "The With advisory lock gem adds advisory locking to ActiveRecord for -PostgreSQL and MySQL. SQLite is also supported, but this uses the filesystem +PostgreSQL and MySQL. SQLite is also supported, but this uses the file system for locks.") (home-page "https://closuretree.github.io/with_advisory_lock/") (license license:expat))) diff --git a/gnu/packages/ruby.scm b/gnu/packages/ruby.scm index 8bde577229..9370f59e2e 100644 --- a/gnu/packages/ruby.scm +++ b/gnu/packages/ruby.scm @@ -2870,7 +2870,7 @@ conversion to (X)HTML.") `(("ruby-listen" ,ruby-listen))) (synopsis "Run a process, and restart when some monitored files change") (description - "Rerun is a tool to launch programs, then monitor the filesystem, and + "Rerun is a tool to launch programs, then monitor the file system, and restart the program when any of the monitored files change. It's written in Ruby, but can be used for all programs.") (home-page "https://github.com/alexch/rerun/") diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 1a716cea77..282df19f24 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -42,7 +42,7 @@ ;; structure called a 'workspace' [1]. This workspace can be found by Go via ;; the GOPATH environment variable. Typically, all Go source code and compiled ;; objects are kept in a single workspace, but GOPATH may be a list of -;; directories [2]. In this go-build-system we create a filesystem union of +;; directories [2]. In this go-build-system we create a file system union of ;; the Go-language dependencies. Previously, we made GOPATH a list of store ;; directories, but stopped because Go programs started keeping references to ;; these directories in Go 1.11: @@ -127,7 +127,7 @@ ;; Code: (define* (setup-go-environment #:key inputs outputs #:allow-other-keys) - "Prepare a Go build environment for INPUTS and OUTPUTS. Build a filesystem + "Prepare a Go build environment for INPUTS and OUTPUTS. Build a file system union of INPUTS. Export GOPATH, which helps the compiler find the source code of the package being built and its dependencies, and GOBIN, which determines where executables (\"commands\") are installed to. This phase is sometimes used diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index 8ca16a4cd8..d42c40932c 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -79,8 +79,8 @@ unused by the time you create anything with that name, but a good shot." (define* (get-temp-link target #:optional (link-prefix (dirname target))) "Like mkstemp!, but instead of creating a new file and giving you the name, it creates a new hardlink to TARGET and gives you the name. Since -cross-filesystem hardlinks don't work, the temp link must be created on the -same filesystem - where in that filesystem it is can be controlled by +cross-file-system hardlinks don't work, the temp link must be created on the +same file system - where in that file system it is can be controlled by LINK-PREFIX." (let try ((tempname (tempname-in link-prefix))) (catch 'system-error -- cgit v1.2.3 From c3634df2a48a5b981a97c85f425784cee9f94bc7 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Sun, 14 Apr 2019 22:03:36 +0200 Subject: gnu: ocaml@4.02: Remove the package, affected by a CVE, and its dependent packages. This fixes . * gnu/packages/ocaml.scm (ocaml-4.02, camlp4-4.02, ocaml4.02-menhir) (ocaml4.02-lablgtk, ocaml4.02-findlib, ocaml4.02-ounit) (ocaml4.02-camlzip, ocaml4.02-ocamlmod, ocaml4.02-zarith) (ocaml4.02-qcheck, ocaml4.02-qtest, ocaml4.02-stringext) (ocaml4.02-bisect, ocaml4.02-bitstring, ocaml4.02-result) (ocaml4.02-topkg, ocaml4.02-rresult, ocaml4.02-sqlite3, ocaml4.02-csv) (ocaml4.02-mtime, ocaml4.02-cmdliner, ocaml4.02-fmt, ocaml4.02-astring) (ocaml4.02-alcotest, ocaml4.02-ppx-tools, ocaml4.02-react, ocaml4.02-ssl) (ocaml4.02-lwt, ocaml4.02-lwt-log, ocaml4.02-logs, ocaml4.02-fpath) (ocaml4.02-bos, ocaml4.02-xmlm, ocaml4.02-ulex, ocaml4.02-uchar) (ocaml4.02-uutf, ocaml4.02-jsonm, ocaml4.02-ocurl, ocaml4.02-base64) (ocaml4.02-omake, ocaml4.02-batteries, ocaml4.02-pcre, ocaml4.02-oasis) (ocaml4.02-js-build-tools, ocaml4.02-bin-prot, ocaml4.02-fieldslib) (ocaml4.02-ppx-core, ocaml4.02-ppx-optcomp, ocaml4.02-ppx-driver) (ocaml4.02-cppo, ocaml4.02-ppx-deriving, ocaml4.02-ppx-type-conv) (ocaml4.02-ppx-inline-test, ocaml4.02-ppx-bench, ocaml4.02-ppx-compare) (ocaml4.02-sexplib, ocaml4.02-typerep, ocaml4.02-variantslib) (ocaml4.02-ppx-sexp-conv, ocaml4.02-ppx-variants-conv) (ocaml4.02-ppx-here, ocaml4.02-ppx-assert, ocaml4.02-ppx-enumerate) (ocaml4.02-ppx-let, ocaml4.02-ppx-typerep-conv, ocaml4.02-ppx-sexp-value) (ocaml4.02-ppx-pipebang, ocaml4.02-ppx-bin-prot, ocaml4.02-ppx-fail) (ocaml4.02-ppx-custom-printf, ocaml4.02-ppx-sexp-message) (ocaml4.02-ppx-fields-conv, ocaml4.02-seq, ocaml4.02-re) (ocaml4.02-ppx-expect, ocaml4.02-ppx-jane, ocaml4.02-core-kernel) (ocaml4.02-async-kernel, ocaml4.02-async-rpc-kernel, ocaml4.02-core) (ocaml4.02-async-unix, ocaml4.02-async-extra, ocaml4.02-async) (ocaml4.02-ocplib-endian, ocaml4.02-easy-format, optcomp) (ocaml4.02-piqilib, ocaml4.02-uuidm, ocaml4.02-graph, ocaml4.02-piqi) (ocaml4.02-camomile, ocaml4.02-zed, ocaml4.02-lambda-term): Remove variables. * guix/build-system/ocaml.scm (default-ocaml4.02) (default-ocaml4.02-findlib, package-with-ocaml4.02) (strip-ocaml4.02-variant): Remove variables. --- gnu/packages/ocaml.scm | 1487 ++----------------------------------------- guix/build-system/ocaml.scm | 22 - 2 files changed, 58 insertions(+), 1451 deletions(-) (limited to 'guix') diff --git a/gnu/packages/ocaml.scm b/gnu/packages/ocaml.scm index 581360af02..36ce6813ca 100644 --- a/gnu/packages/ocaml.scm +++ b/gnu/packages/ocaml.scm @@ -129,10 +129,10 @@ "/lib/ocaml/site-lib")) #:phases (modify-phases %standard-phases (delete 'configure)))) -(define-public ocaml-4.02 +(define-public ocaml-4.07 (package (name "ocaml") - (version "4.02.3") + (version "4.07.1") (source (origin (method url-fetch) (uri (string-append @@ -141,12 +141,7 @@ "/ocaml-" version ".tar.xz")) (sha256 (base32 - "1qwwvy8nzd87hk8rd9sm667nppakiapnx4ypdwcrlnav2dz6kil3")) - (patches - (search-patches - "ocaml-CVE-2015-8869.patch" - "ocaml-Add-a-.file-directive.patch" - "ocaml-enable-ocamldoc-reproducibility.patch")))) + "1f07hgj5k45cylj1q3k5mk8yi02cwzx849b1fwnwia8xlcfqpr6z")))) (build-system gnu-build-system) (native-search-paths (list (search-path-specification @@ -204,25 +199,7 @@ patch-/bin/sh-references: ~a: changing `\"/bin/sh\"' to `~a'~%" (add-after 'install 'check (lambda _ (with-directory-excursion "testsuite" - (invoke "make" "all")))) - (add-before 'check 'prepare-socket-test - (lambda _ - (format (current-error-port) - "Spawning local test web server on port 8080~%") - (when (zero? (primitive-fork)) - (run-server (lambda (request request-body) - (values '((content-type . (text/plain))) - "Hello!")) - 'http '(#:port 8080))) - (let ((file "testsuite/tests/lib-threads/testsocket.ml")) - (format (current-error-port) - "Patching ~a to use localhost port 8080~%" - file) - (substitute* file - (("caml.inria.fr") "localhost") - (("80") "8080") - (("HTTP1.0") "HTTP/1.0")) - #t)))))) + (invoke "make" "all"))))))) (home-page "https://ocaml.org/") (synopsis "The OCaml programming language") (description @@ -235,30 +212,6 @@ functional, imperative and object-oriented styles of programming.") ;; distributed under lgpl2.0. (license (list license:qpl license:lgpl2.0)))) -(define-public ocaml-4.07 - (package - (inherit ocaml-4.02) - (version "4.07.1") - (source (origin - (method url-fetch) - (uri (string-append - "http://caml.inria.fr/pub/distrib/ocaml-" - (version-major+minor version) - "/ocaml-" version ".tar.xz")) - (sha256 - (base32 - "1f07hgj5k45cylj1q3k5mk8yi02cwzx849b1fwnwia8xlcfqpr6z")))) - (arguments - (substitute-keyword-arguments (package-arguments ocaml-4.02) - ((#:phases phases) - `(modify-phases ,phases - (delete 'prepare-socket-test) - (replace 'check - (lambda _ - (with-directory-excursion "testsuite" - (invoke "make" "all")) - #t)))))))) - (define-public ocaml ocaml-4.07) (define-public ocamlbuild @@ -561,23 +514,25 @@ Git-friendly development workflow.") ;; The 'LICENSE' file waives some requirements compared to LGPLv3. (license license:lgpl3))) -(define-public camlp4-4.02 +(define-public camlp4-4.07 (package (name "camlp4") - (version "4.02+6") - (source - (origin - (method git-fetch) - (uri (git-reference - (url "https://github.com/ocaml/camlp4.git") - (commit version))) - (file-name (git-file-name name version)) - (sha256 - (base32 "06yl4q0qazl7g25b0axd1gdkfd4qpqzs1gr5fkvmkrcbz113h1hj")))) + (version "4.07+1") + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://github.com/ocaml/camlp4.git") + (commit version))) + (file-name (git-file-name name version)) + (sha256 + (base32 + "0cxl4hkqcvspvkx4f2k83217rh6051fll9i2yz7cw6m3bq57mdvl")))) (build-system gnu-build-system) - (native-inputs `(("ocaml" ,ocaml-4.02) - ("which" ,which))) - (inputs `(("ocaml" ,ocaml-4.02))) + (native-inputs + `(("ocaml" ,ocaml-4.07) + ("ocamlbuild" ,ocamlbuild) + ("which" ,which))) + (inputs `(("ocaml" ,ocaml-4.07))) (arguments '(#:tests? #f ;no documented test target ;; a race-condition will lead byte and native targets to mkdir _build @@ -618,29 +573,6 @@ syntax of OCaml.") ;; against the library to be released under any terms. (license license:lgpl2.0))) -(define-public camlp4-4.07 - (package - (inherit camlp4-4.02) - (name "camlp4") - (version "4.07+1") - (source - (origin - (method git-fetch) - (uri (git-reference - (url "https://github.com/ocaml/camlp4.git") - (commit version))) - (file-name (git-file-name name version)) - (sha256 - (base32 "0cxl4hkqcvspvkx4f2k83217rh6051fll9i2yz7cw6m3bq57mdvl")))) - (properties - `((ocaml4.02-variant . ,(delay camlp4-4.02)))) - (native-inputs - `(("ocaml" ,ocaml-4.07) - ("ocamlbuild" ,ocamlbuild) - ("which" ,which))) - (inputs - `(("ocaml" ,ocaml-4.07))))) - (define-public camlp4 camlp4-4.07) (define-public camlp5 @@ -847,8 +779,6 @@ Emacs.") (let ((out (assoc-ref outputs "out"))) (setenv "PREFIX" out)) #t))))) - (properties - `((ocaml4.02-variant . ,(delay ocaml4.02-menhir)))) (home-page "http://gallium.inria.fr/~fpottier/menhir") (synopsis "Parser generator") (description "Menhir is a parser generator. It turns high-level grammar @@ -860,13 +790,6 @@ Knuth’s LR(1) parser construction technique.") ;; are QPL licensed. (license (list license:gpl2+ license:qpl)))) -(define-public ocaml4.02-menhir - (package - (inherit ocaml-menhir) - (name "ocaml4.02-menhir") - (inputs `(("ocaml" ,ocaml-4.02))) - (native-inputs '()))) - (define-public ocaml-bigarray-compat (package (name "ocaml-bigarray-compat") @@ -900,8 +823,6 @@ Knuth’s LR(1) parser construction technique.") (base32 "1y38fdvswy6hmppm65qvgdk4pb3ghhnvz7n4ialf46340r1s5p2d")))) (build-system gnu-build-system) - (properties - `((ocaml4.02-variant . ,(delay ocaml4.02-lablgtk)))) (native-inputs `(("camlp4" ,camlp4) ("ocaml" ,ocaml) @@ -952,23 +873,6 @@ libglade (and it an generate OCaml code from .glade files), libpanel, librsvg and quartz.") (license license:lgpl2.1))) -(define-public ocaml4.02-lablgtk - (package - (inherit lablgtk) - (name "ocaml4.02-lablgtk") - (version "2.18.5") - (source (origin - (method url-fetch) - (uri (ocaml-forge-uri name version 1627)) - (sha256 - (base32 - "0cyj6sfdvzx8hw7553lhgwc0krlgvlza0ph3dk9gsxy047dm3wib")))) - (native-inputs - `(("camlp4" ,camlp4-4.02) - ("ocaml" ,ocaml-4.02) - ("findlib" ,ocaml4.02-findlib) - ("pkg-config" ,pkg-config))))) - (define-public unison (package (name "unison") @@ -1111,15 +1015,6 @@ compilation and linkage, there are new frontends of the various OCaml compilers that can directly deal with packages.") (license license:x11))) -(define-public ocaml4.02-findlib - (package - (inherit ocaml-findlib) - (name "ocaml4.02-findlib") - (native-inputs - `(("camlp4" ,camlp4-4.02) - ("m4" ,m4) - ("ocaml" ,ocaml-4.02))))) - ;; note that some tests may hang for no obvious reason. (define-public ocaml-ounit (package @@ -1145,9 +1040,6 @@ compilers that can directly deal with packages.") other XUnit testing frameworks.") (license license:expat))) -(define-public ocaml4.02-ounit - (package-with-ocaml4.02 ocaml-ounit)) - (define-public camlzip (package (name "camlzip") @@ -1190,9 +1082,6 @@ JAR format. It provides functions for reading from and writing to compressed files in these formats.") (license license:lgpl2.1+))) -(define-public ocaml4.02-camlzip - (package-with-ocaml4.02 camlzip)) - (define-public ocamlmod (package (name "ocamlmod") @@ -1217,9 +1106,6 @@ files in these formats.") (description "Generate modules from OCaml source files.") (license license:lgpl2.1+))) ; with an exception -(define-public ocaml4.02-ocamlmod - (package-with-ocaml4.02 ocamlmod)) - (define-public ocaml-zarith (package (name "ocaml-zarith") @@ -1249,9 +1135,6 @@ over big integers. Small integers are represented as Caml unboxed integers, for speed and space economy.") (license license:lgpl2.1+))) ; with an exception -(define-public ocaml4.02-zarith - (package-with-ocaml4.02 ocaml-zarith)) - (define-public ocaml-frontc (package (name "ocaml-frontc") @@ -1322,9 +1205,6 @@ generated instances of the type. It provides combinators for generating instances and printing them.") (license license:lgpl3+))) -(define-public ocaml4.02-qcheck - (package-with-ocaml4.02 ocaml-qcheck)) - (define-public ocaml-qtest (package (name "ocaml-qtest") @@ -1358,9 +1238,6 @@ qcheck library. The possibilities range from trivial tests -- extremely simple to use -- to sophisticated random generation of test cases.") (license license:lgpl3+))) -(define-public ocaml4.02-qtest - (package-with-ocaml4.02 ocaml-qtest)) - (define-public ocaml-stringext (package (name "ocaml-stringext") @@ -1386,9 +1263,6 @@ full_split, cut, rcut, etc..") ;; where it says `mit'. (license license:expat))) -(define-public ocaml4.02-stringext - (package-with-ocaml4.02 ocaml-stringext)) - (define-public ocaml-bisect (package (name "ocaml-bisect") @@ -1434,21 +1308,8 @@ a camlp4-based tool that allows to instrument your application before running tests. After application execution, it is possible to generate a report in HTML format that is the replica of the application source code annotated with code coverage information.") - (properties - `((ocaml4.02-variant . ,(delay ocaml4.02-bisect)))) (license license:gpl3+))) -(define-public ocaml4.02-bisect - (let ((base (package-with-ocaml4.02 (strip-ocaml4.02-variant ocaml-bisect)))) - (package - (inherit base) - (native-inputs - `(("camlp4" ,camlp4-4.02) - ("libxml2" ,libxml2) - ("which" ,which))) - (propagated-inputs - `(("camlp4" ,camlp4-4.02)))))) - (define-public dune (package (name "dune") @@ -1555,8 +1416,6 @@ ocaml-migrate-parsetree") (arguments `(#:tests? #f; Tests fail to build #:jbuild? #t)) - (properties - `((ocaml4.02-variant . ,(delay ocaml4.02-bitstring)))) (home-page "https://github.com/xguerin/bitstring") (synopsis "Bitstrings and bitstring matching for OCaml") (description "Adds Erlang-style bitstrings and matching over bitstrings as @@ -1566,68 +1425,6 @@ as primitives to the language, making it exceptionally simple to use and very powerful.") (license license:isc))) -(define-public ocaml4.02-bitstring - (let ((base (package-with-ocaml4.02 (strip-ocaml4.02-variant ocaml-bitstring)))) - (package - (inherit base) - (version "2.1.1") - (source (origin - (method url-fetch) - (uri (string-append "https://github.com/xguerin/bitstring" - "/archive/v" version ".tar.gz")) - (file-name (string-append "ocaml-bitstring-" version ".tar.gz")) - (sha256 - (base32 - "0vy8ibrxccii1jbsk5q6yh1kxjigqvi7lhhcmizvd5gfhf7mfyc8")) - (patches (search-patches "ocaml-bitstring-fix-configure.patch")))) - (build-system ocaml-build-system) - (arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib - #:configure-flags - (list "CAMLP4OF=camlp4of" "--enable-coverage") - #:make-flags - (list (string-append "BISECTLIB=" - (assoc-ref %build-inputs "bisect") - "/lib/ocaml/site-lib") - (string-append "OCAMLCFLAGS=-g -I " - (assoc-ref %build-inputs "camlp4") - "/lib/ocaml/site-lib/camlp4 -I " - "$(BISECTLIB)/bisect") - (string-append "OCAMLOPTFLAGS=-g -I " - (assoc-ref %build-inputs "camlp4") - "/lib/ocaml/site-lib/camlp4 -I " - "$(BISECTLIB)/bisect")) - #:phases - (modify-phases %standard-phases - (add-after 'install 'link-lib - (lambda* (#:key outputs #:allow-other-keys) - (let* ((out (assoc-ref outputs "out")) - (stubs (string-append out - "/lib/ocaml/site-lib/stubslibs")) - (lib (string-append out - "/lib/ocaml/site-lib/bitstring"))) - (mkdir-p stubs) - (symlink (string-append lib "/dllbitstring.so") - (string-append stubs "/dllbitstring.so"))) - #t)) - (add-before 'configure 'fix-configure - (lambda* (#:key inputs #:allow-other-keys) - (substitute* "Makefile.in" - (("@abs_top_builddir@") - (string-append "@abs_top_builddir@:" (getenv "LIBRARY_PATH")))) - (substitute* "configure" - (("-/bin/sh") (string-append "-" (assoc-ref inputs "bash") - "/bin/sh")))))))) - (native-inputs - `(("camlp4" ,camlp4-4.02) - ("time" ,time) - ("autoconf" ,autoconf) - ("automake" ,automake) - ("bisect" ,ocaml4.02-bisect))) - (propagated-inputs - `(("camlp4" ,camlp4-4.02)))))) - (define-public ocaml-result (package (name "ocaml-result") @@ -1653,9 +1450,6 @@ staying compatible with older version of OCaml should use the Result module defined in this library.") (license license:bsd-3))) -(define-public ocaml4.02-result - (package-with-ocaml4.02 ocaml-result)) - (define-public ocaml-topkg (package (name "ocaml-topkg") @@ -1687,9 +1481,6 @@ configuration and to specify information about the package's distribution, creation and publication procedures.") (license license:isc))) -(define-public ocaml4.02-topkg - (package-with-ocaml4.02 ocaml-topkg)) - (define-public ocaml-rresult (package (name "ocaml-rresult") @@ -1721,9 +1512,6 @@ to operate on the result type available from OCaml 4.03 in the standard library.") (license license:isc))) -(define-public ocaml4.02-rresult - (package-with-ocaml4.02 ocaml-rresult)) - (define-public ocaml-sqlite3 (package (name "ocaml-sqlite3") @@ -1754,9 +1542,6 @@ coexistence with the old (version 2) SQLite and its OCaml wrapper @code{ocaml-sqlite}.") (license license:expat))) -(define-public ocaml4.02-sqlite3 - (package-with-ocaml4.02 ocaml-sqlite3)) - (define-public ocaml-csv (package (name "ocaml-csv") @@ -1783,9 +1568,6 @@ read and write files in this format as well as some convenience functions to manipulate such data.") (license (package-license camlp4)))) -(define-public ocaml4.02-csv - (package-with-ocaml4.02 ocaml-csv)) - (define-public ocaml-mtime (package (name "ocaml-mtime") @@ -1816,9 +1598,6 @@ manipulate such data.") spans without being subject to operating system calendar time adjustments.") (license license:isc))) -(define-public ocaml4.02-mtime - (package-with-ocaml4.02 ocaml-mtime)) - (define-public ocaml-cmdliner (package (name "ocaml-cmdliner") @@ -1842,8 +1621,6 @@ spans without being subject to operating system calendar time adjustments.") #:phases (modify-phases %standard-phases (delete 'configure)))) - (properties - `((ocaml4.02-variant . ,(delay ocaml4.02-cmdliner)))) (home-page "http://erratique.ch/software/cmdliner") (synopsis "Declarative definition of command line interfaces for OCaml") (description "Cmdliner is a module for the declarative definition of command @@ -1854,19 +1631,6 @@ generation. It supports programs with single or multiple commands and respects most of the POSIX and GNU conventions.") (license license:bsd-3))) -(define-public ocaml4.02-cmdliner - (let ((base (package-with-ocaml4.02 (strip-ocaml4.02-variant ocaml-cmdliner)))) - (package - (inherit base) - (version "1.0.2") - (source (origin - (method url-fetch) - (uri (string-append "http://erratique.ch/software/cmdliner/releases/" - "cmdliner-" version ".tbz")) - (sha256 - (base32 - "18jqphjiifljlh9jg8zpl6310p3iwyaqphdkmf89acyaix0s4kj1"))))))) - (define-public ocaml-fmt (package (name "ocaml-fmt") @@ -1899,9 +1663,6 @@ most of the POSIX and GNU conventions.") functions.") (license license:isc))) -(define-public ocaml4.02-fmt - (package-with-ocaml4.02 ocaml-fmt)) - (define-public ocaml-astring (package (name "ocaml-astring") @@ -1935,9 +1696,6 @@ adds a few missing functions and fully exploits OCaml's newfound string immutability.") (license license:isc))) -(define-public ocaml4.02-astring - (package-with-ocaml4.02 ocaml-astring)) - (define-public ocaml-alcotest (package (name "ocaml-alcotest") @@ -1971,9 +1729,6 @@ displayed at the end of the run (with the full logs ready to inspect), with a simple (yet expressive) query language to select the tests to run.") (license license:isc))) -(define-public ocaml4.02-alcotest - (package-with-ocaml4.02 ocaml-alcotest)) - (define-public ocaml-ppx-tools (package (name "ocaml-ppx-tools") @@ -1990,27 +1745,11 @@ simple (yet expressive) query language to select the tests to run.") (arguments `(#:phases (modify-phases %standard-phases (delete 'configure)) #:tests? #f)) - (properties - `((ocaml4.02-variant . ,(delay ocaml4.02-ppx-tools)))) (home-page "https://github.com/alainfrisch/ppx_tools") (synopsis "Tools for authors of ppx rewriters and other syntactic tools") (description "Tools for authors of ppx rewriters and other syntactic tools.") (license license:expat))) -(define-public ocaml4.02-ppx-tools - (let ((base (package-with-ocaml4.02 (strip-ocaml4.02-variant ocaml-ppx-tools)))) - (package - (inherit base) - (version "5.0+4.02.0") - (source - (origin - (method git-fetch) - (uri (git-reference - (url "https://github.com/alainfrisch/ppx_tools.git") - (commit version))) - (sha256 - (base32 "16drjk0qafjls8blng69qiv35a84wlafpk16grrg2i3x19p8dlj8"))))))) - (define-public ocaml-react (package (name "ocaml-react") @@ -2041,9 +1780,6 @@ events and signals. React doesn't define any primitive event or signal, it lets the client choose the concrete timeline.") (license license:bsd-3))) -(define-public ocaml4.02-react - (package-with-ocaml4.02 ocaml-react)) - (define-public ocaml-ssl (package (name "ocaml-ssl") @@ -2083,9 +1819,6 @@ lets the client choose the concrete timeline.") through Transport Layer Security (@dfn{TLS}) encrypted connections.") (license license:lgpl2.1))) -(define-public ocaml4.02-ssl - (package-with-ocaml4.02 ocaml-ssl)) - (define-public ocaml-lwt (package (name "ocaml-lwt") @@ -2128,9 +1861,6 @@ process. Also, in many cases, Lwt threads can interact without the need for locks or other synchronization primitives.") (license license:lgpl2.1))) -(define-public ocaml4.02-lwt - (package-with-ocaml4.02 ocaml-lwt)) - (define-public ocaml-lwt-log (package (name "ocaml-lwt-log") @@ -2155,9 +1885,6 @@ locks or other synchronization primitives.") ocaml lwt.") (license license:lgpl2.1))) -(define-public ocaml4.02-lwt-log - (package-with-ocaml4.02 ocaml-lwt-log)) - (define-public ocaml-logs (package (name "ocaml-logs") @@ -2193,9 +1920,6 @@ performed on sources whose reporting level can be set independently. Log message report is decoupled from logging and is handled by a reporter.") (license license:isc))) -(define-public ocaml4.02-logs - (package-with-ocaml4.02 ocaml-logs)) - (define-public ocaml-fpath (package (name "ocaml-fpath") @@ -2227,9 +1951,6 @@ POSIX or Windows conventions. Fpath processes paths without accessing the file system and is independent from any system library.") (license license:isc))) -(define-public ocaml4.02-fpath - (package-with-ocaml4.02 ocaml-fpath)) - (define-public ocaml-bos (package (name "ocaml-bos") @@ -2266,9 +1987,6 @@ environment, parse command line arguments, interact with the file system and run command line programs.") (license license:isc))) -(define-public ocaml4.02-bos - (package-with-ocaml4.02 ocaml-bos)) - (define-public ocaml-xmlm (package (name "ocaml-xmlm") @@ -2298,9 +2016,6 @@ format. It can process XML documents without a complete in-memory representation of the data.") (license license:isc))) -(define-public ocaml4.02-xmlm - (package-with-ocaml4.02 ocaml-xmlm)) - (define-public ocaml-ulex (package (name "ocaml-ulex") @@ -2331,9 +2046,6 @@ representation of the data.") (description "Lexer generator for Unicode and OCaml.") (license license:expat))) -(define-public ocaml4.02-ulex - (package-with-ocaml4.02 ocaml-ulex)) - (define-public ocaml-uchar (package (name "ocaml-uchar") @@ -2361,9 +2073,6 @@ representation of the data.") `Uchar` module introduced in OCaml 4.03.") (license license:lgpl2.1))) -(define-public ocaml4.02-uchar - (package-with-ocaml4.02 ocaml-uchar)) - (define-public ocaml-uutf (package (name "ocaml-uutf") @@ -2400,9 +2109,6 @@ Functions are also provided to fold over the characters of UTF encoded OCaml string values and to directly encode characters in OCaml Buffer.t values.") (license license:isc))) -(define-public ocaml4.02-uutf - (package-with-ocaml4.02 ocaml-uutf)) - (define-public ocaml-jsonm (package (name "ocaml-jsonm") @@ -2435,9 +2141,6 @@ the JSON data format. It can process JSON text without blocking on IO and without a complete in-memory representation of the data.") (license license:isc))) -(define-public ocaml4.02-jsonm - (package-with-ocaml4.02 ocaml-jsonm)) - (define-public ocaml-ocurl (package (name "ocaml-ocurl") @@ -2466,9 +2169,6 @@ without a complete in-memory representation of the data.") multitude of other network protocols (FTP/SMTP/RTSP/etc).") (license license:isc))) -(define-public ocaml4.02-ocurl - (package-with-ocaml4.02 ocaml-ocurl)) - (define-public ocaml-base64 (package (name "ocaml-base64") @@ -2502,9 +2202,6 @@ that represent binary data in an ASCII string format by translating it into a radix-64 representation. It is specified in RFC 4648.") (license license:isc))) -(define-public ocaml4.02-base64 - (package-with-ocaml4.02 ocaml-base64)) - (define-public ocamlify (package (name "ocamlify") @@ -2558,8 +2255,6 @@ OCaml code.") (lambda* (#:key outputs #:allow-other-keys) (substitute* "mk/osconfig_unix.mk" (("CC = cc") "CC = gcc"))))))) - (properties - `((ocaml4.02-variant . ,(delay ocaml4.02-omake)))) (native-inputs `(("hevea" ,hevea))) (home-page "http://projects.camlcity.org/projects/omake.html") (synopsis "Build system designed for scalability and portability") @@ -2581,20 +2276,6 @@ many additional enhancements, including: license:gpl2)))) ; OMake itself, with ocaml linking exception ; see LICENSE.OMake -(define-public ocaml4.02-omake - (let ((base (package-with-ocaml4.02 (strip-ocaml4.02-variant omake)))) - (package - (inherit base) - (version "0.10.2") - (source (origin - (method url-fetch) - (uri (string-append "http://download.camlcity.org/download/" - "omake-" version ".tar.gz")) - (sha256 - (base32 - "1znnlkpz89hk44byvnl1pr92ym6hwfyyw2qm9clq446r6l2z4m64")) - (patches (search-patches "omake-fix-non-determinism.patch"))))))) - (define-public ocaml-batteries (package (name "ocaml-batteries") @@ -2638,8 +2319,6 @@ many additional enhancements, including: (copy-file "_build/build/mkconf.byte" "build/mkconf.byte") (invoke "make" "all") #t))))) - (properties - `((ocaml4.02-variant . ,(delay ocaml4.02-batteries)))) (home-page "http://batteries.forge.ocamlcore.org/") (synopsis "Development platform for the OCaml programming language") (description "Define a standard set of libraries which may be expected on @@ -2647,19 +2326,6 @@ every compliant installation of OCaml and organize these libraries into a hierarchy of modules.") (license license:lgpl2.1+))) -(define-public ocaml4.02-batteries - (let ((base (package-with-ocaml4.02 (strip-ocaml4.02-variant ocaml-batteries)))) - (package - (inherit base) - (version "2.5.3") - (source (origin - (method url-fetch) - (uri (ocaml-forge-uri "batteries" version 1650)) - (sha256 - (base32 - "1a97w3x2l1jr5x9kj5gqm1x6b0q9fjqdcsvls7arnl3bvzgsia0n")))) - (propagated-inputs '())))) - (define-public ocaml-pcre (package (name "ocaml-pcre") @@ -2697,9 +2363,6 @@ matching and substitution, similar to the functionality offered by the Perl language.") (license license:lgpl2.1+))); with the OCaml link exception -(define-public ocaml4.02-pcre - (package-with-ocaml4.02 ocaml-pcre)) - (define-public ocaml-expect (package (name "ocaml-expect") @@ -2784,9 +2447,6 @@ system in your OCaml projects. It helps to create standard entry points in your build system and allows external tools to analyse your project easily.") (license license:lgpl2.1+))) ; with ocaml static compilation exception -(define-public ocaml4.02-oasis - (package-with-ocaml4.02 ocaml-oasis)) - (define-public ocaml-js-build-tools (package (name "ocaml-js-build-tools") @@ -2810,137 +2470,6 @@ from the oasis build log @end enumerate") (license license:asl2.0))) -(define-public ocaml4.02-js-build-tools - (package-with-ocaml4.02 ocaml-js-build-tools)) - -(define-public ocaml4.02-bin-prot - (package - (name "ocaml4.02-bin-prot") - (version "113.33.03") - (source (janestreet-origin "bin_prot" version - "1ws8c017z8nbj3vw92ndvjk9011f71rmp3llncbv8r5fc76wqv3l")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/bin_prot/") - (synopsis "Binary protocol generator") - (description "This library contains functionality for reading and writing -OCaml-values in a type-safe binary protocol. It is extremely efficient, -typically supporting type-safe marshalling and unmarshalling of even highly -structured values at speeds sufficient to saturate a gigabit connection. The -protocol is also heavily optimized for size, making it ideal for long-term -storage of large amounts of data.") - (license license:asl2.0))) - -(define-public ocaml4.02-fieldslib - (package - (name "ocaml4.02-fieldslib") - (version "113.33.03") - (source (janestreet-origin "fieldslib" version - "1rm3bn54bzk2hlq8f3w067ak8s772w4a8f78i3yh79vxfzq8ncvv")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/fieldslib/") - (synopsis "Syntax extension to record fields") - (description "Syntax extension to define first class values representing -record fields, to get and set record fields, iterate and fold over all fields -of a record and create new record values.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-core - (package - (name "ocaml4.02-ppx-core") - (version "113.33.03") - (source (janestreet-origin "ppx_core" version - "0f69l4czhgssnhb5ds2j9dbqjyz8dp1y3i3x0i4h6pxnms20zbxa")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (inputs `(("ppx-tools" ,ocaml4.02-ppx-tools))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_core/") - (synopsis "Standard library for ppx rewriters") - (description "Ppx_core is a standard library for OCaml AST transformers. -It contains: -@enumerate -@item various auto-generated AST traversal using an open recursion scheme -@item helpers for building AST fragments -@item helpers for matching AST fragments -@item a framework for dealing with attributes and extension points. -@end enumerate") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-optcomp - (package - (name "ocaml4.02-ppx-optcomp") - (version "113.33.03") - (source (janestreet-origin "ppx_optcomp" version - "13an8p2r7sd0d5lv54mlzrxdni47408bwqi3bjcx4m6005170q30")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (propagated-inputs - `(("ppx-tools" ,ocaml4.02-ppx-tools) - ("ppx-core" ,ocaml4.02-ppx-core))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_optcomp/") - (synopsis "Optional compilation for OCaml") - (description "Ppx_optcomp stands for Optional Compilation. It is a tool -used to handle optional compilations of pieces of code depending of the word -size, the version of the compiler, ...") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-driver - (package - (name "ocaml4.02-ppx-driver") - (version "113.33.03") - (source (janestreet-origin "ppx_driver" version - "011zzr45897j49b7iiybb29k7pspcx36mlnp7nh6pxb8b0ga76fh")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam) - ("ppx-optcomp" ,ocaml4.02-ppx-optcomp))) - (propagated-inputs - `(("ppx-optcomp" ,ocaml4.02-ppx-optcomp) - ("ppx-core" ,ocaml4.02-ppx-core))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_driver/") - (synopsis "Feature-full driver for OCaml AST transformers") - (description "A driver is an executable created from a set of OCaml AST -transformers linked together with a command line frontend. The aim is to -provide a tool that can be used to: -@enumerate -@item easily view the pre-processed version of a file, no need to construct a - complex command line: @command{ppx file.ml} will do -@item use a single executable to run several transformations: no need to fork - many times just for pre-processing -@item improved errors for misspelled/misplaced attributes and extension points. -@end enumerate") - (license license:asl2.0))) - (define-public ocaml-cppo (package (name "ocaml-cppo") @@ -2971,639 +2500,61 @@ programs. It allows the definition of simple macros and file inclusion. Cpp oi @end enumerate") (license license:bsd-3))) -(define-public ocaml4.02-cppo - (package-with-ocaml4.02 ocaml-cppo)) - -;; this package is not reproducible. This is related to temporary filenames -;; such as findlib_initxxxxx where xxxxx is random. -(define-public ocaml4.02-ppx-deriving +(define-public ocaml-seq (package - (name "ocaml4.02-ppx-deriving") - (version "4.1") + (name "ocaml-seq") + (version "0.1") (source (origin (method git-fetch) (uri (git-reference - (url "https://github.com/whitequark/ppx_deriving.git") - (commit (string-append "v" version)))) + (url "https://github.com/c-cube/seq.git") + (commit version))) (file-name (git-file-name name version)) (sha256 - (base32 "0cy9p8d8cbcxvqyyv8fz2z9ypi121zrgaamdlp4ld9f3jnwz7my9")))) + (base32 "1cjpsc7q76yfgq9iyvswxgic4kfq2vcqdlmxjdjgd4lx87zvcwrv")))) (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("cppo" ,ocaml4.02-cppo) - ("ounit" ,ocaml4.02-ounit) - ("opam" ,opam))) - (propagated-inputs - `(("result" ,ocaml4.02-result) - ("ppx-tools" ,ocaml4.02-ppx-tools))) (arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib + `(#:tests? #f #:phases (modify-phases %standard-phases - (add-after 'unpack 'make-git-checkout-writable - (lambda _ - (for-each make-file-writable (find-files ".")) - #t)) (delete 'configure) - (add-before 'install 'fix-environment + (delete 'build) + (replace 'install (lambda* (#:key outputs #:allow-other-keys) - ;; the installation procedures looks for the installed module - (setenv "OCAMLPATH" - (string-append (getenv "OCAMLPATH") ":" - (getenv "OCAMLFIND_DESTDIR")))))))) - (home-page "https://github.com/whitequark/ppx_deriving/") - (synopsis "Type-driven code generation for OCaml >=4.02") - (description "Ppx_deriving provides common infrastructure for generating -code based on type definitions, and a set of useful plugins for common tasks.") - (license license:expat))) + (let ((install-dir (string-append (assoc-ref outputs "out") + "/lib/ocaml/site-lib/seq"))) + (mkdir-p install-dir) + (with-output-to-file (string-append install-dir "/META") + (lambda _ + (display "name=\"seq\" +version=\"[distributed with ocaml]\" +description=\"dummy package for compatibility\" +requires=\"\""))) + #t)))))) + (home-page "https://github.com/c-cube/seq") + (synopsis "OCaml's standard iterator type") + (description "This package is a compatibility package for OCaml's +standard iterator type starting from 4.07.") + (license license:lgpl2.1+))) -(define-public ocaml4.02-ppx-type-conv +(define-public ocaml-re (package - (name "ocaml4.02-ppx-type-conv") - (version "113.33.03") + (name "ocaml-re") + (version "1.8.0") (source - (janestreet-origin "ppx_type_conv" version - "1sp602ads2f250nv4d4rgw54d14k7flyhb4w8ff084f657hhmxv2")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (propagated-inputs - `(("ppx-deriving" ,ocaml4.02-ppx-deriving) - ("ppx-core" ,ocaml4.02-ppx-core) - ("ppx-driver" ,ocaml4.02-ppx-driver))) + (origin + (method git-fetch) + (uri (git-reference + (url "https://github.com/ocaml/ocaml-re.git") + (commit version))) + (file-name (git-file-name name version)) + (sha256 + (base32 "0ch6hvmm4ym3w2vghjxf3ka5j1023a37980fqi4zcb7sx756z20i")))) + (build-system dune-build-system) (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_type_conv/") - (synopsis "Support Library for type-driven code generators") - (description "The type_conv library factors out functionality needed by -different preprocessors that generate code from type specifications.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-inline-test - (package - (name "ocaml4.02-ppx-inline-test") - (version "113.33.03") - (source (janestreet-origin "ppx_inline_test" version - "0859ni43fl39dd5g6cxfhq0prxmx59bd2bfq8jafp593ba4q0icq")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam) - ("ppx-core" ,ocaml4.02-ppx-core))) - (propagated-inputs - `(("ppx-driver" ,ocaml4.02-ppx-driver) - ("ppx-tools" ,ocaml4.02-ppx-tools) - ("ppx-core" ,ocaml4.02-ppx-core))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_inline_test/") - (synopsis "Syntax extension for writing in-line tests in ocaml code") - (description "Syntax extension for writing in-line tests in ocaml code.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-bench - (package - (name "ocaml4.02-ppx-bench") - (version "113.33.03") - (source (janestreet-origin "ppx_bench" version - "1hky3y17qpb925rymf97wv54di9gaqdmkix7wpkjw14qzl512b68")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam) - ("ppx-core" ,ocaml4.02-ppx-core))) - (propagated-inputs - `(("ppx-driver" ,ocaml4.02-ppx-driver) - ("ppx-tools" ,ocaml4.02-ppx-tools) - ("ppx-inline-test" ,ocaml4.02-ppx-inline-test) - ("ppx-core" ,ocaml4.02-ppx-core))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_bench/") - (synopsis "Syntax extension for writing in-line benchmarks in ocaml code") - (description "Syntax extension for writing in-line benchmarks in ocaml code.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-compare - (package - (name "ocaml4.02-ppx-compare") - (version "113.33.03") - (source (janestreet-origin "ppx_compare" version - "0bfhi33kq9l4q6zzc6svki2csracz5j4731c3npcy6cs73jynn0z")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam) - ("ppx-core" ,ocaml4.02-ppx-core))) - (propagated-inputs - `(("ppx-driver" ,ocaml4.02-ppx-driver) - ("ppx-tools" ,ocaml4.02-ppx-tools) - ("ppx-core" ,ocaml4.02-ppx-core) - ("ppx-type-conv" ,ocaml4.02-ppx-type-conv))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_compare/") - (synopsis "Generation of comparison functions from types") - (description "Generation of fast comparison functions from type expressions -and definitions. Ppx_compare is a ppx rewriter that derives comparison functions -from type representations. The scaffolded functions are usually much faster -than ocaml's Pervasives.compare. Scaffolding functions also gives you more -flexibility by allowing you to override them for a specific type and more safety -by making sure that you only compare comparable values.") - (license license:asl2.0))) - -(define-public ocaml4.02-sexplib - (package - (name "ocaml4.02-sexplib") - (version "113.33.03") - (source (janestreet-origin "sexplib" version - "1ffjmj8if9lyv965cgn2ld1xv7g52qsr8mqflbm515ck1i8l2ima")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/sexplib/") - (synopsis "Library for serializing OCaml values to and from S-expressions") - (description "Sexplib contains functionality for parsing and pretty-printing -s-expressions.") - (license license:asl2.0))) - -(define-public ocaml4.02-typerep - (package - (name "ocaml4.02-typerep") - (version "113.33.03") - (source (janestreet-origin "typerep" version - "1b9v5bmi824a9d4sx0f40ixq0yfcbiqxafg4a1jx95xg9199zafy")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/typerep/") - (synopsis "Typerep is a library for runtime types") - (description "Typerep is a library for runtime types.") - (license license:asl2.0))) - -(define-public ocaml4.02-variantslib - (package - (name "ocaml4.02-variantslib") - (version "113.33.03") - (source (janestreet-origin "variantslib" version - "05vp799vl38fvl98ga5miwbzh09cnnpapi6q6gdvwyqi6w7s919n")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/variantslib") - (synopsis "OCaml variants as first class values") - (description "OCaml variants as first class values.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-sexp-conv - (package - (name "ocaml4.02-ppx-sexp-conv") - (version "113.33.03") - (source (janestreet-origin "ppx_sexp_conv" version - "1rbj6d5dl625gdxih34xcrdvikci6h8i2dl9x3wraa4qrgishiw7")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam) - ("ppx-core" ,ocaml4.02-ppx-core))) - (propagated-inputs - `(("sexplib" ,ocaml4.02-sexplib) - ("ppx-core" ,ocaml4.02-ppx-core) - ("ppx-type-conv" ,ocaml4.02-ppx-type-conv) - ("ppx-tools" ,ocaml4.02-ppx-tools))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_sexp_conv") - (synopsis "Generation of S-expression conversion functions from type definitions") - (description "Generation of S-expression conversion functions from type -definitions.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-variants-conv - (package - (name "ocaml4.02-ppx-variants-conv") - (version "113.33.03") - (source (janestreet-origin "ppx_variants_conv" version - "0vnn2l1118cj72413d3f7frlw6yc09l8f64jlzkzbgb9bxpalx34")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (propagated-inputs - `(("ppx-core" ,ocaml4.02-ppx-core) - ("variantslib" ,ocaml4.02-variantslib) - ("ppx-tools" ,ocaml4.02-ppx-tools) - ("ppx-type-conv" ,ocaml4.02-ppx-type-conv))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_variants_conv") - (synopsis "Generation of accessor and iteration functions for ocaml variant -types") - (description "Generation of accessor and iteration functions for ocaml -variant types.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-here - (package - (name "ocaml4.02-ppx-here") - (version "113.33.03") - (source (janestreet-origin "ppx_here" version - "1ay8lfxi0qg3ib2zkwh4h0vqk3gjmxaz572gzab0bbxyqn3z86v7")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (propagated-inputs - `(("ppx-driver" ,ocaml4.02-ppx-driver) - ("ppx-core" ,ocaml4.02-ppx-core))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_here") - (synopsis "Expands [%here] into its location") - (description "Expands [%here] into its location.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-assert - (package - (name "ocaml4.02-ppx-assert") - (version "113.33.03") - (source (janestreet-origin "ppx_assert" version - "1k5kxmqkibp5fk25pgz81f3c1r4mgvb5byzf6bnmxd24y60wn46p")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (propagated-inputs - `(("ppx-compare" ,ocaml4.02-ppx-compare) - ("ppx-core" ,ocaml4.02-ppx-core) - ("ppx-driver" ,ocaml4.02-ppx-driver) - ("ppx-sexp-conv" ,ocaml4.02-ppx-sexp-conv) - ("ppx-tools" ,ocaml4.02-ppx-tools) - ("ppx-type-conv" ,ocaml4.02-ppx-type-conv) - ("ppx-sexplib" ,ocaml4.02-sexplib) - ("ppx-here" ,ocaml4.02-ppx-here))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_assert") - (synopsis "Assert-like extension nodes that raise useful errors on failure") - (description "Assert-like extension nodes that raise useful errors on failure.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-enumerate - (package - (name "ocaml4.02-ppx-enumerate") - (version "113.33.03") - (source (janestreet-origin "ppx_enumerate" version - "15g7yfv9wg2h9r6k6q1zrhygmsl4xrfn25mrb0i4czjjivzmxjh4")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (propagated-inputs - `(("ppx-tools" ,ocaml4.02-ppx-tools) - ("ppx-type-conv" ,ocaml4.02-ppx-type-conv) - ("ppx-core" ,ocaml4.02-ppx-core))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_enumerate") - (synopsis "Generate a list containing all values of a finite type") - (description "Ppx_enumerate is a ppx rewriter which generates a definition -for the list of all values of a type (for a type which only has finitely -many values).") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-let - (package - (name "ocaml4.02-ppx-let") - (version "113.33.03") - (source (janestreet-origin "ppx_let" version - "0gd6d3gdaqfwjcs7gaw1qxc30i584q6a86ndaj1bx1q63xqd6yx9")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (propagated-inputs - `(("ppx-driver" ,ocaml4.02-ppx-driver) - ("ppx-core" ,ocaml4.02-ppx-core))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_let") - (synopsis "Monadic let-bindings") - (description "A ppx rewriter for monadic and applicative let bindings, -match expressions, and if expressions.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-typerep-conv - (package - (name "ocaml4.02-ppx-typerep-conv") - (version "113.33.03") - (source (janestreet-origin "ppx_typerep_conv" version - "0g0xqm9s1b2jjvxb8yp69281q2s3bwz6sibn10fvgcdawpa0rmrg")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (propagated-inputs - `(("ppx-tools" ,ocaml4.02-ppx-tools) - ("ppx-type-conv" ,ocaml4.02-ppx-type-conv) - ("ppx-core" ,ocaml4.02-ppx-core) - ("typerep" ,ocaml4.02-typerep))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_typerep_conv") - (synopsis "Generation of runtime types from type declarations") - (description "Automatic generation of runtime types from type definitions.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-sexp-value - (package - (name "ocaml4.02-ppx-sexp-value") - (version "113.33.03") - (source (janestreet-origin "ppx_sexp_value" version - "0m3ag23mbqm0i2pv1dzilfks15ipa5q60mf57a0cd3p0pvarq10g")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (propagated-inputs - `(("ppx-driver" ,ocaml4.02-ppx-driver) - ("ppx-here" ,ocaml4.02-ppx-here) - ("ppx-sexp-conv" ,ocaml4.02-ppx-sexp-conv) - ("ppx-tools" ,ocaml4.02-ppx-tools) - ("ppx-core" ,ocaml4.02-ppx-core))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_sexp_value/") - (synopsis "Simplify building s-expressions from ocaml values") - (description "A ppx rewriter that simplifies building s-expressions from -ocaml values.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-pipebang - (package - (name "ocaml4.02-ppx-pipebang") - (version "113.33.03") - (source (janestreet-origin "ppx_pipebang" version - "1965c7hymp26ncmjs0pfxi2s5jlj60z2c9b194lgcwxqiav56pcw")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (propagated-inputs - `(("ppx-driver" ,ocaml4.02-ppx-driver) - ("ppx-tools" ,ocaml4.02-ppx-tools) - ("ppx-core" ,ocaml4.02-ppx-core))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_pipebang/") - (synopsis "Inline reverse application operators `|>` and `|!`") - (description "A ppx rewriter that inlines reverse application operators -@code{|>} and @code{|!}.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-bin-prot - (package - (name "ocaml4.02-ppx-bin-prot") - (version "113.33.03") - (source (janestreet-origin "ppx_bin_prot" version - "173kjv36giik11zgfvsbzwfbpr66dm2pcha9vf990jgzh8hqz39h")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (propagated-inputs - `(("bin-prot" ,ocaml4.02-bin-prot) - ("ppx-tools" ,ocaml4.02-ppx-tools) - ("ppx-type-conv" ,ocaml4.02-ppx-type-conv) - ("ppx-core" ,ocaml4.02-ppx-core))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_bin_prot/") - (synopsis "Generation of bin_prot readers and writers from types") - (description "Generation of binary serialization and deserialization -functions from type definitions.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-fail - (package - (name "ocaml4.02-ppx-fail") - (version "113.33.03") - (source (janestreet-origin "ppx_fail" version - "1dwgad0f05gqp5rnwf9dcasidpfi7q3mrpazsw3a2vijjblbhjgn")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (propagated-inputs - `(("ppx-driver" ,ocaml4.02-ppx-driver) - ("ppx-tools" ,ocaml4.02-ppx-tools) - ("ppx-here" ,ocaml4.02-ppx-here) - ("ppx-core" ,ocaml4.02-ppx-core))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_fail/") - (synopsis "Add location to calls to failwiths") - (description "Syntax extension that makes [failwiths] always include a -position.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-custom-printf - (package - (name "ocaml4.02-ppx-custom-printf") - (version "113.33.03") - (source (janestreet-origin "ppx_custom_printf" version - "11jlx0n87g2j1vyyp343dibx7lvvwig5j5q0nq0b80kbsq0k6yr8")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (propagated-inputs - `(("ppx-sexp-conv" ,ocaml4.02-ppx-sexp-conv) - ("ppx-tools" ,ocaml4.02-ppx-tools) - ("ppx-core" ,ocaml4.02-ppx-core) - ("ppx-driver" ,ocaml4.02-ppx-driver))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_custom_printf/") - (synopsis "Printf-style format-strings for user-defined string conversion") - (description "Extensions to printf-style format-strings for user-defined -string conversion.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-sexp-message - (package - (name "ocaml4.02-ppx-sexp-message") - (version "113.33.03") - (source (janestreet-origin "ppx_sexp_message" version - "084w1l3gnyw4ri9vbn7bv9b2xkw1520qczfxpxdarfivdrz8xr68")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (propagated-inputs - `(("ppx-driver" ,ocaml4.02-ppx-driver) - ("ppx-here" ,ocaml4.02-ppx-here) - ("ppx-sexp-conv" ,ocaml4.02-ppx-sexp-conv) - ("ppx-tools" ,ocaml4.02-ppx-tools) - ("ppx-core" ,ocaml4.02-ppx-core))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_sexp_message/") - (synopsis "A ppx rewriter for easy construction of s-expressions") - (description "Ppx_sexp_message aims to ease the creation of s-expressions -in OCaml. This is mainly motivated by writing error and debugging messages, -where one needs to construct a s-expression based on various element of the -context such as function arguments.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-fields-conv - (package - (name "ocaml4.02-ppx-fields-conv") - (version "113.33.03") - (source (janestreet-origin "ppx_fields_conv" version - "1vzbdz27g5qhhfs7wx6rjf979q4xyssxqbmp6sc1sxknbghslbdv")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam) - ("ppx-core" ,ocaml4.02-ppx-core))) - (propagated-inputs - `(("fieldslib" ,ocaml4.02-fieldslib) - ("ppx-tools" ,ocaml4.02-ppx-tools) - ("ppx-core" ,ocaml4.02-ppx-core) - ("ppx-type-conv" ,ocaml4.02-ppx-type-conv))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_fields_conv/") - (synopsis "Generation of accessor and iteration functions for ocaml records") - (description "Ppx_fields_conv is a ppx rewriter that can be used to define -first class values representing record fields, and additional routines, to get -and set record fields, iterate and fold over all fields of a record and create -new record values.") - (license license:asl2.0))) - -(define-public ocaml-seq - (package - (name "ocaml-seq") - (version "0.1") - (source - (origin - (method git-fetch) - (uri (git-reference - (url "https://github.com/c-cube/seq.git") - (commit version))) - (file-name (git-file-name name version)) - (sha256 - (base32 "1cjpsc7q76yfgq9iyvswxgic4kfq2vcqdlmxjdjgd4lx87zvcwrv")))) - (build-system ocaml-build-system) - (arguments - `(#:tests? #f - #:phases - (modify-phases %standard-phases - (delete 'configure) - (delete 'build) - (replace 'install - (lambda* (#:key outputs #:allow-other-keys) - (let ((install-dir (string-append (assoc-ref outputs "out") - "/lib/ocaml/site-lib/seq"))) - (mkdir-p install-dir) - (with-output-to-file (string-append install-dir "/META") - (lambda _ - (display "name=\"seq\" -version=\"[distributed with ocaml]\" -description=\"dummy package for compatibility\" -requires=\"\""))) - #t)))))) - (properties - `((ocaml4.02-variant . ,(delay ocaml4.02-seq)))) - (home-page "https://github.com/c-cube/seq") - (synopsis "OCaml's standard iterator type") - (description "This package is a compatibility package for OCaml's -standard iterator type starting from 4.07.") - (license license:lgpl2.1+))) - -(define-public ocaml4.02-seq - (let ((base (package-with-ocaml4.02 (strip-ocaml4.02-variant ocaml-seq)))) - (package - (inherit base) - (arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib - #:tests? #f; no tests - #:phases (modify-phases %standard-phases (delete 'configure))))))) - -(define-public ocaml-re - (package - (name "ocaml-re") - (version "1.8.0") - (source - (origin - (method git-fetch) - (uri (git-reference - (url "https://github.com/ocaml/ocaml-re.git") - (commit version))) - (file-name (git-file-name name version)) - (sha256 - (base32 "0ch6hvmm4ym3w2vghjxf3ka5j1023a37980fqi4zcb7sx756z20i")))) - (build-system dune-build-system) - (arguments - `(#:tests? #f - #:build-flags (list "--profile" "release"))) + `(#:tests? #f + #:build-flags (list "--profile" "release"))) (propagated-inputs `(("ocaml-seq" ,ocaml-seq))) (native-inputs @@ -3620,265 +2571,6 @@ standard iterator type starting from 4.07.") @end enumerate") (license license:expat))) -(define-public ocaml4.02-re - (package-with-ocaml4.02 ocaml-re)) - -(define-public ocaml4.02-ppx-expect - (package - (name "ocaml4.02-ppx-expect") - (version "113.33.03") - (source (janestreet-origin "ppx_expect" version - "03sbs4s5i8l9syr45v25f5hzy7msd2b47k2a9wsq9m43d4imgkrc")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (propagated-inputs - `(("fieldslib" ,ocaml4.02-fieldslib) - ("ppx-tools" ,ocaml4.02-ppx-tools) - ("ppx-assert" ,ocaml4.02-ppx-assert) - ("ppx-compare" ,ocaml4.02-ppx-compare) - ("ppx-core" ,ocaml4.02-ppx-core) - ("ppx-custom-printf" ,ocaml4.02-ppx-custom-printf) - ("ppx-driver" ,ocaml4.02-ppx-driver) - ("ppx-fields-conv" ,ocaml4.02-ppx-fields-conv) - ("ppx-inline-test" ,ocaml4.02-ppx-inline-test) - ("ppx-sexp-conv" ,ocaml4.02-ppx-sexp-conv) - ("ppx-variants-conv" ,ocaml4.02-ppx-variants-conv) - ("re" ,ocaml4.02-re) - ("sexplib" ,ocaml4.02-sexplib) - ("variantslib" ,ocaml4.02-variantslib))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_expect/") - (synopsis "Cram like framework for OCaml") - (description "Expect-test is a framework for writing tests in OCaml, similar -to Cram. Expect-tests mimic the existing inline tests framework with the -let%expect_test construct. The body of an expect-test can contain -output-generating code, interleaved with %expect extension expressions to denote -the expected output.") - (license license:asl2.0))) - -(define-public ocaml4.02-ppx-jane - (package - (name "ocaml4.02-ppx-jane") - (version "113.33.03") - (source (janestreet-origin "ppx_jane" version - "0bjxkhmzgm6x9dcvjwybbccn34khbvyyjimcbaja30fp6qcqk5yl")) - (build-system ocaml-build-system) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("opam" ,opam))) - (propagated-inputs - `(("ppx-assert" ,ocaml4.02-ppx-assert) - ("ppx-bench" ,ocaml4.02-ppx-bench) - ("ppx-bin-prot" ,ocaml4.02-ppx-bin-prot) - ("ppx-compare" ,ocaml4.02-ppx-compare) - ("ppx-custom-printf" ,ocaml4.02-ppx-custom-printf) - ("ppx-deriving" ,ocaml4.02-ppx-deriving) - ("ppx-enumerate" ,ocaml4.02-ppx-enumerate) - ("ppx-expect" ,ocaml4.02-ppx-expect) - ("ppx-fail" ,ocaml4.02-ppx-fail) - ("ppx-fields-conv" ,ocaml4.02-ppx-fields-conv) - ("ppx-here" ,ocaml4.02-ppx-here) - ("ppx-inline-test" ,ocaml4.02-ppx-inline-test) - ("ppx-let" ,ocaml4.02-ppx-let) - ("ppx-pipebang" ,ocaml4.02-ppx-pipebang) - ("ppx-sexp-conv" ,ocaml4.02-ppx-sexp-conv) - ("ppx-sexp-message" ,ocaml4.02-ppx-sexp-message) - ("ppx-sexp-value" ,ocaml4.02-ppx-sexp-value) - ("ppx-typerep-conv" ,ocaml4.02-ppx-typerep-conv) - ("ppx-variants-conv" ,ocaml4.02-ppx-variants-conv))) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/ppx_jane/") - (synopsis "Standard Jane Street ppx rewriters") - (description "Ppx_jane is a ppx_driver including all standard ppx rewriters.") - (license license:asl2.0))) - -(define-public ocaml4.02-core-kernel - (package - (name "ocaml4.02-core-kernel") - (version "113.33.03") - (source (janestreet-origin "core_kernel" version - "0fl23jrwivixawhxinbwaw9cabqnzn7fini7dxpxjjvkxdc8ip5y")) - (native-inputs - `(("js-build-tools" ,ocaml4.02-js-build-tools) - ("ppx-jane" ,ocaml4.02-ppx-jane) - ("opam" ,opam))) - (propagated-inputs - `(("bin_prot" ,ocaml4.02-bin-prot) - ("ppx-assert" ,ocaml4.02-ppx-assert) - ("ppx-bench" ,ocaml4.02-ppx-bench) - ("ppx-driver" ,ocaml4.02-ppx-driver) - ("ppx-expect" ,ocaml4.02-ppx-expect) - ("ppx-inline-test" ,ocaml4.02-ppx-inline-test) - ("typerep" ,ocaml4.02-typerep) - ("sexplib" ,ocaml4.02-sexplib) - ("variantslib" ,ocaml4.02-variantslib) - ("result" ,ocaml4.02-result) - ("fieldslib" ,ocaml4.02-fieldslib))) - (build-system ocaml-build-system) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/core_kernel/") - (synopsis "Portable standard library for OCaml") - (description "Core is an alternative to the OCaml standard library. - -Core_kernel is the system-independent part of Core. It is aimed for cases when -the full Core is not available, such as in Javascript.") - (license license:asl2.0))) - -(define-public ocaml4.02-async-kernel - (package - (name "ocaml4.02-async-kernel") - (version "113.33.03") - (source (janestreet-origin "async_kernel" version - "04bjsaa23j831r09r38x6xx9nhryvp0z5ihickvhxqa4fb2snyvd")) - (native-inputs - `(("oasis" ,ocaml-oasis) - ("js-build-tools" ,ocaml4.02-js-build-tools) - ("ppx-jane" ,ocaml4.02-ppx-jane) - ("opam" ,opam))) - (propagated-inputs - `(("core-kernel" ,ocaml4.02-core-kernel))) - (build-system ocaml-build-system) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/async_kernel/") - (synopsis "Monadic concurrency library") - (description "Async-kernel is a library for concurrent programming in OCaml.") - (license license:asl2.0))) - -(define-public ocaml4.02-async-rpc-kernel - (package - (name "ocaml4.02-async-rpc-kernel") - (version "113.33.03") - (source (janestreet-origin "async_rpc_kernel" version - "0y97h9pkb00v7jpf87m8cbb0ffkclj9g26ph6sq97q8dpisnkjwh")) - (native-inputs - `(("oasis" ,ocaml-oasis) - ("js-build-tools" ,ocaml4.02-js-build-tools) - ("ppx-jane" ,ocaml4.02-ppx-jane) - ("opam" ,opam))) - (propagated-inputs - `(("async-kernel" ,ocaml4.02-async-kernel))) - (build-system ocaml-build-system) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/async_rpc_kernel/") - (synopsis "Platform-independent core of the Async RPC library") - (description "Async_rpc_kernel is the platform-independent core of -the Async RPC library.") - (license license:asl2.0))) - -(define-public ocaml4.02-core - (package - (name "ocaml4.02-core") - (version "113.33.03") - (source (janestreet-origin "core" version - "1znll157qg56g9d3247fjibv1hxv3r9wxgr4nhy19j2vzdh6a268")) - (native-inputs - `(("oasis" ,ocaml-oasis) - ("js-build-tools" ,ocaml4.02-js-build-tools) - ("ppx-jane" ,ocaml4.02-ppx-jane) - ("opam" ,opam))) - (propagated-inputs - `(("core-kernel" ,ocaml4.02-core-kernel))) - (build-system ocaml-build-system) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/core/") - (synopsis "Alternative to OCaml's standard library") - (description "The Core suite of libraries is an alternative to OCaml's -standard library that was developed by Jane Street.") - (license license:asl2.0))) - -(define-public ocaml4.02-async-unix - (package - (name "ocaml4.02-async-unix") - (version "113.33.03") - (source (janestreet-origin "async_unix" version - "1fwl0lfrizllcfjk8hk8m7lsz9ha2jg6qgk4gssfyz377qvpcq4h")) - (native-inputs - `(("oasis" ,ocaml-oasis) - ("js-build-tools" ,ocaml4.02-js-build-tools) - ("ppx-jane" ,ocaml4.02-ppx-jane) - ("opam" ,opam))) - (propagated-inputs - `(("async-kernel" ,ocaml4.02-async-kernel) - ("core" ,ocaml4.02-core))) - (build-system ocaml-build-system) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/async_unix") - (synopsis "Asynchronous execution library for Unix") - (description "Async_unix is an asynchronous execution library for Unix.") - (license license:asl2.0))) - -(define-public ocaml4.02-async-extra - (package - (name "ocaml4.02-async-extra") - (version "113.33.03") - (source (janestreet-origin "async_extra" version - "1si8jgiq5xh5sl9f2b7f9p17p7zx5h1pg557x2cxywi2x7pxqg4f")) - (native-inputs - `(("oasis" ,ocaml-oasis) - ("js-build-tools" ,ocaml4.02-js-build-tools) - ("ppx-jane" ,ocaml4.02-ppx-jane) - ("opam" ,opam))) - (propagated-inputs - `(("async-rpc-kernel" ,ocaml4.02-async-rpc-kernel) - ("async-unix" ,ocaml4.02-async-unix) - ("core" ,ocaml4.02-core))) - (build-system ocaml-build-system) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/async_extra") - (synopsis "Extra functionnalities for the async library") - (description "Async_extra provides additional functionnalities for the -async library.") - (license license:asl2.0))) - -(define-public ocaml4.02-async - (package - (name "ocaml4.02-async") - (version "113.33.03") - (source (janestreet-origin "async" version - "0210fyhcs12kpmmd26015bgivkfd2wqkyn3c5wd7688d0f872y25")) - (native-inputs - `(("oasis" ,ocaml-oasis) - ("js-build-tools" ,ocaml4.02-js-build-tools) - ("ppx-jane" ,ocaml4.02-ppx-jane) - ("opam" ,opam))) - (propagated-inputs - `(("async-extra" ,ocaml4.02-async-extra))) - (build-system ocaml-build-system) - (arguments - (ensure-keyword-arguments janestreet-arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib))) - (home-page "https://github.com/janestreet/async") - (synopsis "Monadic concurrency library") - (description "Async is a library for concurrent programming in OCaml.") - (license license:asl2.0))) - (define-public ocaml-ocplib-endian (package (name "ocaml-ocplib-endian") @@ -3904,9 +2596,6 @@ strings, bytes and bigstring (Bigarrys of chars), and provides submodules for big- and little-endian, with their unsafe counter-parts.") (license license:lgpl2.1))) -(define-public ocaml4.02-ocplib-endian - (package-with-ocaml4.02 ocaml-ocplib-endian)) - (define-public ocaml-cstruct (package (name "ocaml-cstruct") @@ -4038,39 +2727,6 @@ JSON.") Format module of the OCaml standard library.") (license license:bsd-3))) -(define-public ocaml4.02-easy-format - (package-with-ocaml4.02 ocaml-easy-format)) - -(define-public optcomp - (package - (name "optcomp") - (version "1.6") - (source - (origin - (method git-fetch) - (uri (git-reference - (url "https://github.com/diml/optcomp.git") - (commit version))) - (file-name (git-file-name name version)) - (sha256 - (base32 "0bm4f3fs9g1yiz48hdxvcjwnrgymwisqilxhmm87ndz81wp47zfy")))) - (build-system ocaml-build-system) - (arguments - `(#:ocaml ,ocaml-4.02 - #:findlib ,ocaml4.02-findlib - #:use-make? #t - #:make-flags - (list (string-append "BUILDFLAGS=\"-cflags -I," - (assoc-ref %build-inputs "camlp4") - "/lib/ocaml/site-lib/camlp4/Camlp4Parsers\"")))) - (native-inputs `(("camlp4" ,camlp4-4.02))) - (propagated-inputs `(("camlp4" ,camlp4-4.02))) - (home-page "https://github.com/diml/optcomp") - (synopsis "Optional compilation for OCaml") - (description "Optcomp provides an optional compilation facility with -cpp-like directives.") - (license license:bsd-3))) - (define-public ocaml-piqilib (package (name "ocaml-piqilib") @@ -4132,9 +2788,6 @@ cpp-like directives.") tool and piqi-ocaml.") (license license:asl2.0))) -(define-public ocaml4.02-piqilib - (package-with-ocaml4.02 ocaml-piqilib)) - (define-public ocaml-uuidm (package (name "ocaml-uuidm") @@ -4166,9 +2819,6 @@ unique identifiers (UUIDs) version 3, 5 (named based with MD5, SHA-1 hashing) and 4 (random based) according to RFC 4122.") (license license:isc))) -(define-public ocaml4.02-uuidm - (package-with-ocaml4.02 ocaml-uuidm)) - (define-public ocaml-graph (package (name "ocaml-graph") @@ -4197,9 +2847,6 @@ and 4 (random based) according to RFC 4122.") (description "OCamlgraph is a generic graph library for OCaml.") (license license:lgpl2.1))) -(define-public ocaml4.02-graph - (package-with-ocaml4.02 ocaml-graph)) - (define-public ocaml-piqi (package (name "ocaml-piqi") @@ -4228,8 +2875,6 @@ and 4 (random based) according to RFC 4122.") (propagated-inputs `(("num" ,ocaml-num) ("piqilib" ,ocaml-piqilib))) - (properties - `((ocaml4.02-variant . ,(delay ocaml4.02-piqi)))) (home-page "https://github.com/alavrik/piqi-ocaml") (synopsis "Protocol serialization system for OCaml") (description "Piqi is a multi-format data serialization system for OCaml. @@ -4237,13 +2882,6 @@ It provides a uniform interface for serializing OCaml data structures to JSON, XML and Protocol Buffers formats.") (license license:asl2.0))) -(define-public ocaml4.02-piqi - (let ((base (package-with-ocaml4.02 (strip-ocaml4.02-variant ocaml-piqi)))) - (package - (inherit base) - (propagated-inputs - `(("piqilib" ,ocaml4.02-piqilib)))))) - (define-public bap (package (name "bap") @@ -4335,9 +2973,6 @@ library is currently designed for Unicode Standard 3.2.") ;; with an exception for linked libraries to use a different license (license license:lgpl2.0+))) -(define-public ocaml4.02-camomile - (package-with-ocaml4.02 ocaml-camomile)) - (define-public ocaml-zed (package (name "ocaml-zed") @@ -4365,9 +3000,6 @@ to write text editors, edition widgets, readlines, etc. You just have to connect an engine to your inputs and rendering functions to get an editor.") (license license:bsd-3))) -(define-public ocaml4.02-zed - (package-with-ocaml4.02 ocaml-zed)) - (define-public ocaml-lambda-term (package (name "ocaml-lambda-term") @@ -4399,9 +3031,6 @@ manipulation than, for example, ncurses, by providing a native OCaml interface instead of bindings to a C library.") (license license:bsd-3))) -(define-public ocaml4.02-lambda-term - (package-with-ocaml4.02 ocaml-lambda-term)) - (define-public ocaml-utop (package (name "ocaml-utop") diff --git a/guix/build-system/ocaml.scm b/guix/build-system/ocaml.scm index 07c69fac76..cbd33d9a89 100644 --- a/guix/build-system/ocaml.scm +++ b/guix/build-system/ocaml.scm @@ -28,9 +28,7 @@ #:use-module (srfi srfi-1) #:export (%ocaml-build-system-modules package-with-ocaml4.01 - package-with-ocaml4.02 strip-ocaml4.01-variant - strip-ocaml4.02-variant default-findlib default-ocaml lower @@ -94,14 +92,6 @@ (let ((module (resolve-interface '(gnu packages ocaml)))) (module-ref module 'ocaml4.01-findlib))) -(define (default-ocaml4.02) - (let ((ocaml (resolve-interface '(gnu packages ocaml)))) - (module-ref ocaml 'ocaml-4.02))) - -(define (default-ocaml4.02-findlib) - (let ((module (resolve-interface '(gnu packages ocaml)))) - (module-ref module 'ocaml4.02-findlib))) - (define* (package-with-explicit-ocaml ocaml findlib old-prefix new-prefix #:key variant-property) "Return a procedure of one argument, P. The procedure creates a package @@ -161,24 +151,12 @@ pre-defined variants." "ocaml-" "ocaml4.01-" #:variant-property 'ocaml4.01-variant)) -(define package-with-ocaml4.02 - (package-with-explicit-ocaml (delay (default-ocaml4.02)) - (delay (default-ocaml4.02-findlib)) - "ocaml-" "ocaml4.02-" - #:variant-property 'ocaml4.02-variant)) - (define (strip-ocaml4.01-variant p) "Remove the 'ocaml4.01-variant' property from P." (package (inherit p) (properties (alist-delete 'ocaml4.01-variant (package-properties p))))) -(define (strip-ocaml4.02-variant p) - "Remove the 'ocaml4.02-variant' property from P." - (package - (inherit p) - (properties (alist-delete 'ocaml4.02-variant (package-properties p))))) - (define* (lower name #:key source inputs native-inputs outputs system target (ocaml (default-ocaml)) -- cgit v1.2.3 From 554b30d2aca0cb27804d92863b87209593b023c6 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Fri, 26 Apr 2019 14:54:52 +0200 Subject: self: Rebuild translated manuals. * guix/self.scm (info-manual): Run po4a and related commands to generate translated texi files before building translated manuals. * guix/build/po.scm: New file. * Makefile.am (MODULES_NOT_COMPILED): Add it. --- Makefile.am | 1 + guix/build/po.scm | 69 ++++++++++++++++++++++++++++ guix/self.scm | 131 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 201 insertions(+) create mode 100644 guix/build/po.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index f25900de0f..05940719cd 100644 --- a/Makefile.am +++ b/Makefile.am @@ -54,6 +54,7 @@ nodist_noinst_SCRIPTS = \ # Modules that are not compiled but are installed nonetheless, such as # build-side modules with unusual dependencies. MODULES_NOT_COMPILED = \ + guix/build/po.scm \ guix/man-db.scm include gnu/local.mk diff --git a/guix/build/po.scm b/guix/build/po.scm new file mode 100644 index 0000000000..47ff67541c --- /dev/null +++ b/guix/build/po.scm @@ -0,0 +1,69 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Julien Lepiller +;;; +;;; 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 . + +(define-module (guix build po) + #:use-module (ice-9 match) + #:use-module (ice-9 peg) + #:use-module (ice-9 regex) + #:use-module (ice-9 textual-ports) + #:export (read-po-file)) + +;; A small parser for po files +(define-peg-pattern po-file body (* (or comment entry whitespace))) +(define-peg-pattern whitespace body (or " " "\t" "\n")) +(define-peg-pattern comment-chr body (range #\space #\頋)) +(define-peg-pattern comment none (and "#" (* comment-chr) "\n")) +(define-peg-pattern entry all + (and (ignore (* whitespace)) (ignore "msgid ") msgid + (ignore (* whitespace)) (ignore "msgstr ") msgstr)) +(define-peg-pattern escape body (or "\\\\" "\\\"" "\\n")) +(define-peg-pattern str-chr body (or " " "!" (and (ignore "\\") "\"") + "\\n" (and (ignore "\\") "\\") + (range #\# #\頋))) +(define-peg-pattern msgid all content) +(define-peg-pattern msgstr all content) +(define-peg-pattern content body + (and (ignore "\"") (* str-chr) (ignore "\"") + (? (and (ignore (* whitespace)) content)))) + +(define (parse-tree->assoc parse-tree) + "Converts a po PARSE-TREE to an association list." + (define regex (make-regexp "\\\\n")) + (match parse-tree + ('() '()) + ((entry parse-tree ...) + (match entry + ((? string? entry) + (parse-tree->assoc parse-tree)) + ;; empty msgid + (('entry ('msgid ('msgstr msgstr))) + (parse-tree->assoc parse-tree)) + ;; empty msgstr + (('entry ('msgid msgid) 'msgstr) + (parse-tree->assoc parse-tree)) + (('entry ('msgid msgid) ('msgstr msgstr)) + (acons (regexp-substitute/global #f regex msgid 'pre "\n" 'post) + (regexp-substitute/global #f regex msgstr 'pre "\n" 'post) + (parse-tree->assoc parse-tree))))))) + +(define (read-po-file port) + "Read a .po file from PORT and return an alist of msgid and msgstr." + (let ((tree (peg:tree (match-pattern + po-file + (get-string-all port))))) + (parse-tree->assoc tree))) diff --git a/guix/self.scm b/guix/self.scm index 2a10d1d25f..68b87051e9 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -60,6 +60,8 @@ ("gzip" (ref '(gnu packages compression) 'gzip)) ("bzip2" (ref '(gnu packages compression) 'bzip2)) ("xz" (ref '(gnu packages compression) 'xz)) + ("po4a" (ref '(gnu packages gettext) 'po4a)) + ("gettext" (ref '(gnu packages gettext) 'gettext-minimal)) (_ #f)))) ;no such package @@ -253,8 +255,134 @@ DOMAIN, a gettext domain." (computed-file (string-append "guix-locale-" domain) build)) +(define (translate-texi-manuals source) + "Return the translated texinfo manuals built from SOURCE." + (define po4a + (specification->package "po4a")) + + (define gettext + (specification->package "gettext")) + + (define glibc-utf8-locales + (module-ref (resolve-interface '(gnu packages base)) + 'glibc-utf8-locales)) + + (define documentation + (file-append* source "doc")) + + (define documentation-po + (file-append* source "po/doc")) + + (define build + (with-imported-modules '((guix build utils) (guix build po)) + #~(begin + (use-modules (guix build utils) (guix build po) + (ice-9 match) (ice-9 regex) (ice-9 textual-ports) + (srfi srfi-1)) + + (mkdir #$output) + + (copy-recursively #$documentation "." + #:log (%make-void-port "w")) + + (for-each + (lambda (file) + (copy-file file (basename file))) + (find-files #$documentation-po ".*.po$")) + + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (setenv "PATH" #+(file-append gettext "/bin")) + (setenv "LC_ALL" "en_US.UTF-8") + (setlocale LC_ALL "en_US.UTF-8") + + (define (translate-tmp-texi po source output) + "Translate Texinfo file SOURCE using messages from PO, and write +the result to OUTPUT." + (invoke #+(file-append po4a "/bin/po4a-translate") + "-M" "UTF-8" "-L" "UTF-8" "-k" "0" "-f" "texinfo" + "-m" source "-p" po "-l" output)) + + (define (make-ref-regex msgid end) + (make-regexp (string-append + "ref\\{" + (string-join (string-split (regexp-quote msgid) #\ ) + "[ \n]+") + end))) + + (define (translate-cross-references content translations) + "Take CONTENT, a string representing a .texi file and translate any +cross-reference in it (@ref, @xref and @pxref) that have a translation in +TRANSLATIONS, an alist of msgid and msgstr." + (fold + (lambda (elem content) + (match elem + ((msgid . msgstr) + ;; Empty translations and strings containing some special characters + ;; cannot be the name of a section. + (if (or (equal? msgstr "") + (string-any (lambda (chr) + (member chr '(#\{ #\} #\( #\) #\newline #\,))) + msgid)) + content + ;; Otherwise, they might be the name of a section, so we + ;; need to translate any occurence in @(p?x?)ref{...}. + (let ((regexp1 (make-ref-regex msgid ",")) + (regexp2 (make-ref-regex msgid "\\}"))) + (regexp-substitute/global + #f regexp2 + (regexp-substitute/global + #f regexp1 content 'pre "ref{" msgstr "," 'post) + 'pre "ref{" msgstr "}" 'post)))))) + content translations)) + + (define (translate-texi po lang) + "Translate the manual for one language LANG using the PO file." + (let ((translations (call-with-input-file po read-po-file))) + (translate-tmp-texi po "guix.texi" + (string-append "guix." lang ".texi.tmp")) + (translate-tmp-texi po "contributing.texi" + (string-append "contributing." lang ".texi.tmp")) + (let* ((texi-name (string-append "guix." lang ".texi")) + (tmp-name (string-append texi-name ".tmp"))) + (with-output-to-file texi-name + (lambda _ + (format #t "~a" + (translate-cross-references + (call-with-input-file tmp-name get-string-all) + translations))))) + (let* ((texi-name (string-append "contributing." lang ".texi")) + (tmp-name (string-append texi-name ".tmp"))) + (with-output-to-file texi-name + (lambda _ + (format #t "~a" + (translate-cross-references + (call-with-input-file tmp-name get-string-all) + translations))))))) + + (for-each (lambda (po) + (match (reverse (string-split po #\.)) + ((_ lang _ ...) + (translate-texi po lang)))) + (find-files "." "^guix-manual\\.[a-z]{2}(_[A-Z]{2})?\\.po$")) + + (for-each + (lambda (file) + (copy-file file (string-append #$output "/" file))) + (append + (find-files "." "contributing\\..*\\.texi$") + (find-files "." "guix\\..*\\.texi$")))))) + + (computed-file "guix-translated-texinfo" build)) + (define (info-manual source) "Return the Info manual built from SOURCE." + (define po4a + (specification->package "po4a")) + + (define gettext + (specification->package "gettext")) + (define texinfo (module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo)) @@ -327,6 +455,8 @@ DOMAIN, a gettext domain." ;; see those images and produce image references in the Info output. (copy-recursively #$documentation "." #:log (%make-void-port "w")) + (copy-recursively #+(translate-texi-manuals source) "." + #:log (%make-void-port "w")) (delete-file-recursively "images") (symlink (string-append #$output "/images") "images") @@ -578,6 +708,7 @@ Info manual." ;; us to avoid an extra dependency on guile-gdbm-ffi. #:extra-files `(("guix/man-db.scm" ,(local-file "../guix/man-db.scm")) + ("guix/build/po.scm" ,(local-file "../guix/build/po.scm")) ("guix/store/schema.sql" ,(local-file "../guix/store/schema.sql"))) -- cgit v1.2.3 From 0663302618d6bef25bf09f694a91ab05fe7a9bd7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 28 Apr 2019 15:05:41 +0200 Subject: describe: Provide a hint when origin detection fails. * guix/scripts/describe.scm (display-checkout-info): Add call to 'display-hint' in the error case. --- guix/scripts/describe.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index b6287d3a4c..fa6b6cae37 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -18,6 +18,7 @@ ;;; along with GNU Guix. If not, see . (define-module (guix scripts describe) + #:use-module ((guix config) #:select (%guix-version)) #:use-module ((guix ui) #:hide (display-profile-content)) #:use-module (guix channels) #:use-module (guix scripts) @@ -114,7 +115,12 @@ within a Git checkout." (lambda () (repository-discover (dirname program))) (lambda (key err) - (leave (G_ "failed to determine origin~%"))))) + (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)))) -- cgit v1.2.3 From d824cfbabeb0780c9ea7a6dab02c47b6a4d029c6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 27 Apr 2019 18:04:00 +0200 Subject: guix package: Add 'install', 'remove', and 'upgrade' aliases. * guix/scripts/install.scm, guix/scripts/remove.scm, guix/scripts/upgrade.scm, tests/guix-package-aliases.sh: New files. * Makefile.am (MODULES, SH_TESTS): Add them. * po/guix/POTFILES.in: Add them. * guix/scripts/package.scm (guix-package): Split with... (guix-package*): ... this. New procedure. * doc/guix.texi (Invoking guix package): Document them. (Binary Installation, Application Setup, Package Management) (Packages with Multiple Outputs, Package Modules) (X.509 Certificates, Installing Debugging Files): Use 'guix install' in simple examples. * etc/completion/bash/guix (_guix_complete): Handle "install", "remove", and "upgrade". --- Makefile.am | 4 ++ doc/guix.texi | 39 +++++++++++++------ etc/completion/bash/guix | 11 +++++- guix/scripts/install.scm | 80 +++++++++++++++++++++++++++++++++++++++ guix/scripts/package.scm | 11 +++++- guix/scripts/remove.scm | 77 +++++++++++++++++++++++++++++++++++++ guix/scripts/upgrade.scm | 88 +++++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 3 ++ tests/guix-package-aliases.sh | 58 ++++++++++++++++++++++++++++ 9 files changed, 358 insertions(+), 13 deletions(-) create mode 100644 guix/scripts/install.scm create mode 100644 guix/scripts/remove.scm create mode 100644 guix/scripts/upgrade.scm create mode 100644 tests/guix-package-aliases.sh (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 05940719cd..076f1c7a71 100644 --- a/Makefile.am +++ b/Makefile.am @@ -224,6 +224,9 @@ MODULES = \ guix/scripts/archive.scm \ guix/scripts/import.scm \ guix/scripts/package.scm \ + guix/scripts/install.scm \ + guix/scripts/remove.scm \ + guix/scripts/upgrade.scm \ guix/scripts/gc.scm \ guix/scripts/hash.scm \ guix/scripts/pack.scm \ @@ -425,6 +428,7 @@ SH_TESTS = \ tests/guix-pack-localstatedir.sh \ tests/guix-pack-relocatable.sh \ tests/guix-package.sh \ + tests/guix-package-aliases.sh \ tests/guix-package-net.sh \ tests/guix-system.sh \ tests/guix-archive.sh \ diff --git a/doc/guix.texi b/doc/guix.texi index c28ded1cf1..6c3dc7d208 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -689,7 +689,7 @@ You can confirm that Guix is working by installing a sample package into the root profile: @example -# guix package -i hello +# guix install hello @end example The binary installation tarball can be (re)produced and verified simply @@ -1577,7 +1577,7 @@ available with Guix and then define the @code{GUIX_LOCPATH} environment variable: @example -$ guix package -i glibc-locales +$ guix install glibc-locales $ export GUIX_LOCPATH=$HOME/.guix-profile/lib/locale @end example @@ -1677,7 +1677,7 @@ Multiple Outputs}). For instance, the following command installs fonts for Chinese languages: @example -guix package -i font-adobe-source-han-sans:cn +guix install font-adobe-source-han-sans:cn @end example @cindex @code{xterm} @@ -2492,7 +2492,7 @@ emacs-guix, The Emacs-Guix Reference Manual}), after installing with it): @example -guix package -i emacs-guix +guix install emacs-guix @end example @menu @@ -2610,6 +2610,7 @@ is: @example guix package @var{options} @end example + @cindex transactions Primarily, @var{options} specifies the operations to be performed during the transaction. Upon completion, a new profile is created, but @@ -2623,6 +2624,22 @@ For example, to remove @code{lua} and install @code{guile} and guix package -r lua -i guile guile-cairo @end example +@cindex aliases, for @command{guix package} +For your convenience, we also provide the following aliases: + +@itemize +@item +@command{guix install} is an alias for @command{guix package -i}, +@item +@command{guix remove} is an alias for @command{guix package -r}, +@item +and @command{guix upgrade} is an alias for @command{guix package -u}. +@end itemize + +These aliases are less expressive than @command{guix package} and provide +fewer options, so in some cases you'll probably want to use @command{guix +package} directly. + @command{guix package} also supports a @dfn{declarative approach} whereby the user specifies the exact set of packages to be available and passes it @i{via} the @option{--manifest} option @@ -3312,7 +3329,7 @@ like to discuss this project, join us on @email{guix-devel@@gnu.org}. Often, packages defined in Guix have a single @dfn{output}---i.e., the source package leads to exactly one directory in the store. When running -@command{guix package -i glibc}, one installs the default output of the +@command{guix install glibc}, one installs the default output of the GNU libc package; the default output is called @code{out}, but its name can be omitted as shown in this command. In this particular case, the default output of @code{glibc} contains all the C header files, shared @@ -3328,14 +3345,14 @@ separate output, called @code{doc}. To install the main GLib output, which contains everything but the documentation, one would run: @example -guix package -i glib +guix install glib @end example @cindex documentation The command to install its documentation is: @example -guix package -i glib:doc +guix install glib:doc @end example Some packages install programs with different ``dependency footprints''. @@ -4986,7 +5003,7 @@ module exports a variable named @code{emacs}, which is bound to a The @code{(gnu packages @dots{})} module name space is automatically scanned for packages by the command-line tools. For -instance, when running @code{guix package -i emacs}, all the @code{(gnu +instance, when running @code{guix install emacs}, all the @code{(gnu packages @dots{})} modules are scanned until one that exports a package object whose name is @code{emacs} is found. This package search facility is implemented in the @code{(gnu packages)} module. @@ -23634,7 +23651,7 @@ pointed to by the @code{GIT_SSL_CAINFO} environment variable. Thus, you would typically run something like: @example -$ guix package -i nss-certs +$ guix install nss-certs $ export SSL_CERT_DIR="$HOME/.guix-profile/etc/ssl/certs" $ export SSL_CERT_FILE="$HOME/.guix-profile/etc/ssl/certs/ca-certificates.crt" $ export GIT_SSL_CAINFO="$SSL_CERT_FILE" @@ -23645,7 +23662,7 @@ variable to point to a certificate bundle, so you would have to run something like this: @example -$ guix package -i nss-certs +$ guix install nss-certs $ export CURL_CA_BUNDLE="$HOME/.guix-profile/etc/ssl/certs/ca-certificates.crt" @end example @@ -25427,7 +25444,7 @@ installs the debugging information for the GNU C Library and for GNU Guile: @example -guix package -i glibc:debug guile:debug +guix install glibc:debug guile:debug @end example GDB must then be told to look for debug files in the user's profile, by diff --git a/etc/completion/bash/guix b/etc/completion/bash/guix index 3d2b3ddda7..edfb627e87 100644 --- a/etc/completion/bash/guix +++ b/etc/completion/bash/guix @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès +# Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès # # This file is part of GNU Guix. # @@ -167,6 +167,15 @@ _guix_complete () else _guix_complete_available_package "$word_at_point" fi + elif _guix_is_command "install" + then + _guix_complete_available_package "$word_at_point" + elif _guix_is_command "remove" + then + _guix_complete_installed_package "$word_at_point" + elif _guix_is_command "upgrade" + then + _guix_complete_installed_package "$word_at_point" elif _guix_is_command "build" then if _guix_is_dash_L diff --git a/guix/scripts/install.scm b/guix/scripts/install.scm new file mode 100644 index 0000000000..d88e86e77a --- /dev/null +++ b/guix/scripts/install.scm @@ -0,0 +1,80 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts install) + #:use-module (guix ui) + #:use-module (guix scripts package) + #:use-module (guix scripts build) + #:use-module (guix scripts) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-install)) + +(define (show-help) + (display (G_ "Usage: guix install [OPTION] PACKAGES... +Install the given PACKAGES. +This is an alias for 'guix package -i'.\n")) + (display (G_ " + -p, --profile=PROFILE use PROFILE instead of the user's default profile")) + ;; '--bootstrap' not shown here. + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (newline) + (show-build-options-help) + (newline) + (show-transformation-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix install"))) + + ;; Preserve some of the 'guix package' options. + (append (filter (lambda (option) + (any (cut member <> (option-names option)) + '("profile" "dry-run" "verbosity" "bootstrap"))) + %package-options) + + %transformation-options + %standard-build-options))) + +(define (guix-install . args) + (define (handle-argument arg result arg-handler) + ;; Treat all non-option arguments as package specs. + (values (alist-cons 'install arg result) + arg-handler)) + + (define opts + (parse-command-line args %options + (list %package-default-options #f) + #:argument-handler handle-argument)) + + (guix-package* opts)) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 564236988e..aa27984ea2 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -58,7 +58,11 @@ delete-generations delete-matching-generations display-search-paths - guix-package)) + guix-package + + (%options . %package-options) + (%default-options . %package-default-options) + guix-package*)) (define %store (make-parameter #f)) @@ -899,6 +903,11 @@ processed, #f otherwise." (parse-command-line args %options (list %default-options #f) #:argument-handler handle-argument)) + (guix-package* opts)) + +(define (guix-package* opts) + "Run the 'guix package' command on OPTS, an alist resulting for command-line +option processing with 'parse-command-line'." (with-error-handling (or (process-query opts) (parameterize ((%store (open-connection)) diff --git a/guix/scripts/remove.scm b/guix/scripts/remove.scm new file mode 100644 index 0000000000..2f06ea4f37 --- /dev/null +++ b/guix/scripts/remove.scm @@ -0,0 +1,77 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts remove) + #:use-module (guix ui) + #:use-module (guix scripts package) + #:use-module (guix scripts build) + #:use-module (guix scripts) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-remove)) + +(define (show-help) + (display (G_ "Usage: guix remove [OPTION] PACKAGES... +Remove the given PACKAGES. +This is an alias for 'guix package -r'.\n")) + (display (G_ " + -p, --profile=PROFILE use PROFILE instead of the user's default profile")) + ;; '--bootstrap' not shown here. + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (newline) + (show-build-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix remove"))) + + ;; Preserve some of the 'guix package' options. + (append (filter (lambda (option) + (any (cut member <> (option-names option)) + '("profile" "dry-run" "verbosity" "bootstrap"))) + %package-options) + + %standard-build-options))) + +(define (guix-remove . args) + (define (handle-argument arg result arg-handler) + ;; Treat all non-option arguments as package specs. + (values (alist-cons 'remove arg result) + arg-handler)) + + (define opts + (parse-command-line args %options + (list %package-default-options #f) + #:argument-handler handle-argument)) + + (guix-package* opts)) diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm new file mode 100644 index 0000000000..7f14a2fdbe --- /dev/null +++ b/guix/scripts/upgrade.scm @@ -0,0 +1,88 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts upgrade) + #:use-module (guix ui) + #:use-module (guix scripts package) + #:use-module (guix scripts build) + #:use-module (guix scripts) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:export (guix-upgrade)) + +(define (show-help) + (display (G_ "Usage: guix upgrade [OPTION] [REGEXP] +Upgrade packages that match REGEXP. +This is an alias for 'guix package -u'.\n")) + (display (G_ " + -p, --profile=PROFILE use PROFILE instead of the user's default profile")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (newline) + (show-build-options-help) + (newline) + (show-transformation-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix upgrade"))) + + ;; Preserve some of the 'guix package' options. + (append (filter (lambda (option) + (any (cut member <> (option-names option)) + '("profile" "dry-run" "verbosity"))) + %package-options) + + %transformation-options + %standard-build-options))) + +(define (guix-upgrade . args) + (define (handle-argument arg result arg-handler) + ;; Accept at most one non-option argument, and treat it as an upgrade + ;; regexp. + (match (assq-ref result 'upgrade) + (#f + (values (alist-cons 'upgrade arg + (alist-delete 'upgrade result)) + arg-handler)) + (_ + (leave (G_ "~A: extraneous argument~%") arg)))) + + (define opts + (parse-command-line args %options + (list `((upgrade . #f) + ,@%package-default-options) + #f) + #:argument-handler handle-argument)) + + (guix-package* opts)) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index a2c89db981..91de60efc7 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -41,6 +41,9 @@ guix/scripts/build.scm guix/discovery.scm guix/scripts/download.scm guix/scripts/package.scm +guix/scripts/install.scm +guix/scripts/remove.scm +guix/scripts/upgrade.scm guix/scripts/gc.scm guix/scripts/hash.scm guix/scripts/import.scm diff --git a/tests/guix-package-aliases.sh b/tests/guix-package-aliases.sh new file mode 100644 index 0000000000..64ed2fbb67 --- /dev/null +++ b/tests/guix-package-aliases.sh @@ -0,0 +1,58 @@ +# GNU Guix --- Functional package management for GNU +# Copyright © 2019 Ludovic Courtès +# +# 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 . + +# +# Test the `guix package' aliases. +# + +guix install --version + +readlink_base () +{ + basename `readlink "$1"` +} + +profile="t-profile-$$" +rm -f "$profile" + +trap 'rm -f "$profile" "$profile-"[0-9]*' EXIT + +guix install --bootstrap guile-bootstrap -p "$profile" +test -x "$profile/bin/guile" + +# Make sure '-r' isn't passed as-is to 'guix package'. +if guix install -r guile-bootstrap -p "$profile" --bootstrap +then false; else true; fi +test -x "$profile/bin/guile" + +guix upgrade --version +guix upgrade -n +guix upgrade gui.e -n +if guix upgrade foo bar -n; +then false; else true; fi + +guix remove --version +guix remove --bootstrap guile-bootstrap -p "$profile" +! test -x "$profile/bin/guile" +test `guix package -p "$profile" -I | wc -l` -eq 0 + +if guix remove -p "$profile" this-is-not-installed --bootstrap +then false; else true; fi + +if guix remove -i guile-bootstrap -p "$profile" --bootstrap +then false; else true; fi -- cgit v1.2.3 From 9d3053819dfd834a1c29a03427c41d8524b8a7d5 Mon Sep 17 00:00:00 2001 From: rendaw <7e9wc56emjakcm@s.rendaw.me> Date: Mon, 29 Apr 2019 12:08:51 +0200 Subject: file-systems: Support the 'no-atime' flag. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/build/syscalls.scm (MS_NOATIME): New variable. * gnu/build/file-systems.scm (mount-flags->bit-mask): Support it. * doc/guix.texi (File Systems): Document it and add cross-references to the relevant documentation. Co-authored-by: Ludovic Courtès --- doc/guix.texi | 9 +++++++-- gnu/build/file-systems.scm | 2 ++ guix/build/syscalls.scm | 2 ++ 3 files changed, 11 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 8f6e5bc20c..39d2ee476a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10753,10 +10753,15 @@ corresponding device mapping established. This is a list of symbols denoting mount flags. Recognized flags include @code{read-only}, @code{bind-mount}, @code{no-dev} (disallow access to special files), @code{no-suid} (ignore setuid and setgid -bits), and @code{no-exec} (disallow program execution.) +bits), @code{no-atime} (do not update file access times), and @code{no-exec} +(disallow program execution). @xref{Mount-Unmount-Remount,,, libc, The GNU C +Library Reference Manual}, for more information on these flags. @item @code{options} (default: @code{#f}) -This is either @code{#f}, or a string denoting mount options. +This is either @code{#f}, or a string denoting mount options passed to the +file system driver. @xref{Mount-Unmount-Remount,,, libc, The GNU C Library +Reference Manual}, for details and run @command{man 8 mount} for options for +various file systems. @item @code{mount?} (default: @code{#t}) This value indicates whether to automatically mount the file system when diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index c468144170..8bb10d574d 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -575,6 +575,8 @@ corresponds to the symbols listed in FLAGS." (logior MS_NODEV (loop rest))) (('no-exec rest ...) (logior MS_NOEXEC (loop rest))) + (('no-atime rest ...) + (logior MS_NOATIME (loop rest))) (() 0)))) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 66d63a2931..3316dc8dc5 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -39,6 +39,7 @@ MS_NODEV MS_NOEXEC MS_REMOUNT + MS_NOATIME MS_BIND MS_MOVE MS_STRICTATIME @@ -451,6 +452,7 @@ the returned procedure is called." (define MS_NODEV 4) (define MS_NOEXEC 8) (define MS_REMOUNT 32) +(define MS_NOATIME 1024) (define MS_BIND 4096) (define MS_MOVE 8192) (define MS_STRICTATIME 16777216) -- cgit v1.2.3 From da56f10971e0b6f32969b10e38ed043b2c99bb82 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 29 Apr 2019 10:41:11 +0200 Subject: guix package: Add 'guix search' alias. * guix/scripts/search.scm: New file. * Makefile.am (MODULES): Add it. * po/guix/POTFILES.in: Add it. * tests/guix-package-aliases.sh: Add test. * doc/guix.texi (Invoking guix package): Document it and use it in a couple of examples. --- Makefile.am | 1 + doc/guix.texi | 13 +++++---- guix/scripts/search.scm | 67 +++++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 1 + tests/guix-package-aliases.sh | 2 ++ 5 files changed, 79 insertions(+), 5 deletions(-) create mode 100644 guix/scripts/search.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 076f1c7a71..36f3bc5c27 100644 --- a/Makefile.am +++ b/Makefile.am @@ -227,6 +227,7 @@ MODULES = \ guix/scripts/install.scm \ guix/scripts/remove.scm \ guix/scripts/upgrade.scm \ + guix/scripts/search.scm \ guix/scripts/gc.scm \ guix/scripts/hash.scm \ guix/scripts/pack.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 39d2ee476a..fcee57d9cd 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2630,6 +2630,8 @@ For your convenience, we also provide the following aliases: @itemize @item +@command{guix search} is an alias for @command{guix package -s}, +@item @command{guix install} is an alias for @command{guix package -i}, @item @command{guix remove} is an alias for @command{guix package -r}, @@ -2953,12 +2955,13 @@ name: gmp @dots{} @end example -It is also possible to refine search results using several @code{-s} -flags. For example, the following command returns a list of board -games: +It is also possible to refine search results using several @code{-s} flags to +@command{guix package}, or several arguments to @command{guix search}. For +example, the following command returns a list of board games (this time using +the @command{guix search} alias): @example -$ guix package -s '\' -s game | recsel -p name +$ guix search '\' game | recsel -p name name: gnubg @dots{} @end example @@ -2973,7 +2976,7 @@ for cryptographic libraries, filters out Haskell, Perl, Python, and Ruby libraries, and prints the name and synopsis of the matching packages: @example -$ guix package -s crypto -s library | \ +$ guix search crypto library | \ recsel -e '! (name ~ "^(ghc|perl|python|ruby)")' -p name,synopsis @end example diff --git a/guix/scripts/search.scm b/guix/scripts/search.scm new file mode 100644 index 0000000000..8fceb83668 --- /dev/null +++ b/guix/scripts/search.scm @@ -0,0 +1,67 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts search) + #:use-module (guix ui) + #:use-module (guix scripts package) + #:use-module (guix scripts) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-search)) + +(define (show-help) + (display (G_ "Usage: guix search [OPTION] REGEXPS... +Search for packages matching REGEXPS.")) + (display (G_" +This is an alias for 'guix package -s'.\n")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix search"))))) + +(define (guix-search . args) + (define (handle-argument arg result) + ;; Treat all non-option arguments as regexps. + (cons `(query search ,(or arg "")) + result)) + + (define opts + (args-fold* args %options + (lambda (opt name arg . rest) + (leave (G_ "~A: unrecognized option~%") name)) + handle-argument + '())) + + (unless (assoc-ref opts 'query) + (leave (G_ "missing arguments: no regular expressions to search for~%"))) + + (guix-package* opts)) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 91de60efc7..ceee589b2e 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -44,6 +44,7 @@ guix/scripts/package.scm guix/scripts/install.scm guix/scripts/remove.scm guix/scripts/upgrade.scm +guix/scripts/search.scm guix/scripts/gc.scm guix/scripts/hash.scm guix/scripts/import.scm diff --git a/tests/guix-package-aliases.sh b/tests/guix-package-aliases.sh index 64ed2fbb67..5c68664093 100644 --- a/tests/guix-package-aliases.sh +++ b/tests/guix-package-aliases.sh @@ -56,3 +56,5 @@ then false; else true; fi if guix remove -i guile-bootstrap -p "$profile" --bootstrap then false; else true; fi + +guix search '\' game | grep '^name: gnubg' -- cgit v1.2.3 From 88401314f9b00aa4a990cef750fcfce1bfec2327 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Tue, 30 Apr 2019 13:56:29 +0200 Subject: guix: Fix typo in docstring. * guix/build/syscalls.scm (device-in-use?): Fix typo. --- guix/build/syscalls.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 3316dc8dc5..749616ceb1 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -692,7 +692,7 @@ mounted at FILE." (define* (device-in-use? device) "Return #t if the block DEVICE is in use, #f otherwise. This is inspired -from fdisk_device_is_used function of util-linux. This is particulary useful +from fdisk_device_is_used function of util-linux. This is particularly useful for devices that do not appear in /proc/self/mounts like overlayfs lowerdir backend device." (let*-values (((fd) (open-fdes device O_RDONLY)) -- cgit v1.2.3 From e13bd3088d43ccc967459e0194a7b7255a4c577f Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Tue, 30 Apr 2019 14:13:41 +0200 Subject: guix: Fix another typo in another docstring. * guix/build/clojure-utils.scm (include-list\exclude-list): Fix typo. --- guix/build/clojure-utils.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/clojure-utils.scm b/guix/build/clojure-utils.scm index 027777b4d1..9f7334bc8d 100644 --- a/guix/build/clojure-utils.scm +++ b/guix/build/clojure-utils.scm @@ -215,7 +215,7 @@ results from compiling LIB." (define* (include-list\exclude-list include-list exclude-list #:key all-list) - "Given INCLUDE-LIST and EXCLUDE-LIST, replace all occurences of #:all by + "Given INCLUDE-LIST and EXCLUDE-LIST, replace all occurrences of #:all by slicing ALL-LIST into them and compute their list difference." (define (replace-#:all ls all-ls) (append-map (match-lambda -- cgit v1.2.3