From patchwork Tue Jun 22 09:08:20 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 30617 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 3465627BC81; Tue, 22 Jun 2021 10:09:14 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H2,SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id B6D4227BC78 for ; Tue, 22 Jun 2021 10:09:13 +0100 (BST) Received: from localhost ([::1]:46126 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcPA-0008Sy-NW for patchwork@mira.cbaines.net; Tue, 22 Jun 2021 05:09:12 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:58900) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lvcP0-0008Sd-Ko for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:02 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:54494) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcP0-00031B-4Y for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lvcP0-0007nE-0Q for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#49169] [PATCH 01/11] records: Support field sanitizers. References: <20210622090221.15182-1-ludo@gnu.org> In-Reply-To: <20210622090221.15182-1-ludo@gnu.org> Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 22 Jun 2021 09:09:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 49169 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 49169@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 49169-submit@debbugs.gnu.org id=B49169.162435293129887 (code B ref 49169); Tue, 22 Jun 2021 09:09:01 +0000 Received: (at 49169) by debbugs.gnu.org; 22 Jun 2021 09:08:51 +0000 Received: from localhost ([127.0.0.1]:37795 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcOp-0007lx-4D for submit@debbugs.gnu.org; Tue, 22 Jun 2021 05:08:51 -0400 Received: from eggs.gnu.org ([209.51.188.92]:32824) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcOl-0007lE-Uk for 49169@debbugs.gnu.org; Tue, 22 Jun 2021 05:08:49 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:52810) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcOg-0002n1-Og; Tue, 22 Jun 2021 05:08:42 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=49370 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcOg-0000B8-Gu; Tue, 22 Jun 2021 05:08:42 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 22 Jun 2021 11:08:20 +0200 Message-Id: <20210622090830.15561-1-ludo@gnu.org> X-Mailer: git-send-email 2.32.0 MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/records.scm (make-syntactic-constructor): Add #:sanitizers. [field-sanitizer]: New procedure. [wrap-field-value]: Honor F's sanitizer. (define-record-type*)[field-sanitizer]: New procedure. Pass #:sanitizer to 'make-syntactic-constructor'. * tests/records.scm ("define-record-type* & sanitize") ("define-record-type* & sanitize & thunked"): New tests. --- guix/records.scm | 65 +++++++++++++++++++++++++++++++++++++---------- tests/records.scm | 38 +++++++++++++++++++++++++++ 2 files changed, 89 insertions(+), 14 deletions(-) diff --git a/guix/records.scm b/guix/records.scm index 3d54a51956..ed94c83dac 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2018 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -120,7 +120,8 @@ context of the definition of a thunked field." "Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects all of EXPECTED fields to be initialized. DEFAULTS is the list of FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked -fields, and DELAYED is the list of identifiers of delayed fields. +fields, DELAYED is the list of identifiers of delayed fields, and SANITIZERS +is the list of FIELD/SANITIZER tuples. ABI-COOKIE is the cookie (an integer) against which to check the run-time ABI of TYPE matches the expansion-time ABI." @@ -130,6 +131,7 @@ of TYPE matches the expansion-time ABI." #:this-identifier this-identifier #:delayed delayed #:innate innate + #:sanitizers sanitizers #:defaults defaults) (define-syntax name (lambda (s) @@ -169,19 +171,30 @@ of TYPE matches the expansion-time ABI." (define (innate-field? f) (memq (syntax->datum f) 'innate)) + (define field-sanitizer + (let ((lst (map (match-lambda + ((f p) + (list (syntax->datum f) p))) + #'sanitizers))) + (lambda (f) + (or (and=> (assoc-ref lst (syntax->datum f)) car) + #'(lambda (x) x))))) + (define (wrap-field-value f value) - (cond ((thunked-field? f) - #`(lambda (x) - (syntax-parameterize ((#,this-identifier - (lambda (s) - (syntax-case s () - (id - (identifier? #'id) - #'x))))) - #,value))) - ((delayed-field? f) - #`(delay #,value)) - (else value))) + (let* ((sanitizer (field-sanitizer f)) + (value #`(#,sanitizer #,value))) + (cond ((thunked-field? f) + #`(lambda (x) + (syntax-parameterize ((#,this-identifier + (lambda (s) + (syntax-case s () + (id + (identifier? #'id) + #'x))))) + #,value))) + ((delayed-field? f) + #`(delay #,value)) + (else value)))) (define default-values ;; List of symbol/value tuples. @@ -291,6 +304,19 @@ 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. +A field can also have an associated \"sanitizer\", which is a procedure that +takes a user-supplied field value and returns a \"sanitized\" value for the +field: + + (define-record-type* thing make-thing + thing? + this-thing + (name thing-name + (sanitize (lambda (value) + (cond ((string? value) value) + ((symbol? value) (symbol->string value)) + (else (throw 'bad! value))))))) + It is possible to copy an object 'x' created with 'thing' like this: (thing (inherit x) (name \"bar\")) @@ -307,6 +333,14 @@ inherited." (field-default-value #'(field properties ...))) (_ #f))) + (define (field-sanitizer s) + (syntax-case s (sanitize) + ((field (sanitize proc) _ ...) + (list #'field #'proc)) + ((field _ properties ...) + (field-sanitizer #'(field properties ...))) + (_ #f))) + (define-field-property-predicate delayed-field? delayed) (define-field-property-predicate thunked-field? thunked) (define-field-property-predicate innate-field? innate) @@ -376,6 +410,8 @@ inherited." (innate (filter-map innate-field? field-spec)) (defaults (filter-map field-default-value #'((field properties ...) ...))) + (sanitizers (filter-map field-sanitizer + #'((field properties ...) ...))) (cookie (compute-abi-cookie field-spec))) (with-syntax (((field-spec* ...) (map field-spec->srfi-9 field-spec)) @@ -421,6 +457,7 @@ of a record instantiation" #:this-identifier #'this-identifier #:delayed #,delayed #:innate #,innate + #:sanitizers #,sanitizers #:defaults #,defaults))))) ((_ type syntactic-ctor ctor pred (field get properties ...) ...) diff --git a/tests/records.scm b/tests/records.scm index 706bb3dbfd..d014e7a995 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -283,6 +283,44 @@ (equal? (foo-bar y) 1)) ;promise was already forced (eq? (foo-baz y) 'b))))) +(test-assert "define-record-type* & sanitize" + (begin + (define-record-type* foo make-foo + foo? + (bar foo-bar + (default "bar") + (sanitize (lambda (x) (string-append x "!"))))) + + (let* ((p (foo)) + (q (foo (inherit p))) + (r (foo (inherit p) (bar "baz"))) + (s (foo (bar "baz")))) + (and (string=? (foo-bar p) "bar!") + (equal? q p) + (string=? (foo-bar r) "baz!") + (equal? s r))))) + +(test-assert "define-record-type* & sanitize & thunked" + (let ((sanitized 0)) + (define-record-type* foo make-foo + foo? + (bar foo-bar + (default "bar") + (sanitize (lambda (x) + (set! sanitized (+ 1 sanitized)) + (string-append x "!"))))) + + (let ((p (foo))) + (and (string=? (foo-bar p) "bar!") + (string=? (foo-bar p) "bar!") ;twice + (= sanitized 1) ;sanitizer was called at init time only + (let ((q (foo (bar "baz")))) + (and (string=? (foo-bar q) "baz!") + (string=? (foo-bar q) "baz!") ;twice + (= sanitized 2) + (let ((r (foo (inherit q)))) + (and (string=? (foo-bar r) "baz!") + (= sanitized 2))))))))) ;no re-sanitization (test-assert "define-record-type* & wrong field specifier" (let ((exp '(begin (define-record-type* foo make-foo From patchwork Tue Jun 22 09:08:21 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 30619 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id E5EF727BC81; Tue, 22 Jun 2021 10:09:17 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H2,SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 935F627BC78 for ; Tue, 22 Jun 2021 10:09:16 +0100 (BST) Received: from localhost ([::1]:46210 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcPD-00005a-Hk for patchwork@mira.cbaines.net; Tue, 22 Jun 2021 05:09:15 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:58902) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lvcP3-0008Tx-OV for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:06 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:54500) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcP1-000328-5x for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lvcP0-0007nU-W4 for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#49169] [PATCH 02/11] packages: Allow inputs to be plain package lists. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 22 Jun 2021 09:09:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 49169 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 49169@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 49169-submit@debbugs.gnu.org id=B49169.162435293529932 (code B ref 49169); Tue, 22 Jun 2021 09:09:02 +0000 Received: (at 49169) by debbugs.gnu.org; 22 Jun 2021 09:08:55 +0000 Received: from localhost ([127.0.0.1]:37802 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcOq-0007m9-Go for submit@debbugs.gnu.org; Tue, 22 Jun 2021 05:08:54 -0400 Received: from eggs.gnu.org ([209.51.188.92]:32828) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcOn-0007lG-2e for 49169@debbugs.gnu.org; Tue, 22 Jun 2021 05:08:49 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:52812) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcOh-0002nV-Ce; Tue, 22 Jun 2021 05:08:43 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=49370 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcOh-0000B8-2N; Tue, 22 Jun 2021 05:08:43 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 22 Jun 2021 11:08:21 +0200 Message-Id: <20210622090830.15561-2-ludo@gnu.org> X-Mailer: git-send-email 2.32.0 In-Reply-To: <20210622090830.15561-1-ludo@gnu.org> References: <20210622090830.15561-1-ludo@gnu.org> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/packages.scm (add-input-label, sanitize-inputs): New procedures. ()[inputs, propagated-inputs, native-inputs]: Add 'sanitize' property. * doc/guix.texi (Defining Packages, package Reference): (Defining Package Variants): Adjust examples accordingly. * tests/packages.scm ("transaction-upgrade-entry, zero upgrades, propagated inputs") ("transaction-upgrade-entry, grafts") ("package-transitive-inputs") ("package-transitive-supported-systems") ("package-closure") ("supported-package?") ("package-derivation, inputs deduplicated") ("package-transitive-native-search-paths") ("package-grafts, indirect grafts") ("package-grafts, indirect grafts, propagated inputs") ("package-grafts, same replacement twice") ("package-grafts, dependency on several outputs") ("replacement also grafted") ("package->bag, sensitivity to %current-target-system") ("package->bag, propagated inputs") ("package->bag, sensitivity to %current-system") ("package-input-rewriting/spec, identity") ("package-input-rewriting, identity"): Use the label-less input style. --- doc/guix.texi | 44 +++++++++++++++++------- guix/packages.scm | 35 +++++++++++++++++-- tests/packages.scm | 86 ++++++++++++++++++++++------------------------ 3 files changed, 106 insertions(+), 59 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 3557c977e1..1a3ac85e58 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6462,7 +6462,7 @@ package looks like this: "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i")))) (build-system gnu-build-system) (arguments '(#:configure-flags '("--enable-silent-rules"))) - (inputs `(("gawk" ,gawk))) + (inputs (list gawk)) (synopsis "Hello, GNU world: An example GNU package") (description "Guess what GNU Hello prints!") (home-page "https://www.gnu.org/software/hello/") @@ -6550,8 +6550,8 @@ Reference Manual}). @item The @code{inputs} field specifies inputs to the build process---i.e., -build-time or run-time dependencies of the package. Here, we define an -input called @code{"gawk"} whose value is that of the @code{gawk} +build-time or run-time dependencies of the package. Here, we add +an input, a reference to the @code{gawk} variable; @code{gawk} is itself bound to a @code{} object. @cindex backquote (quasiquote) @@ -6675,20 +6675,41 @@ list, typically containing sequential keyword-value pairs. @itemx @code{native-inputs} (default: @code{'()}) @itemx @code{propagated-inputs} (default: @code{'()}) @cindex inputs, of packages -These fields list dependencies of the package. Each one is a list of -tuples, where each tuple has a label for the input (a string) as its +These fields list dependencies of the package. Each element of these +lists is either a package, origin, or other ``file-like object'' +(@pxref{G-Expressions}); to specify the output of that file-like object +that should be used, pass a two-element list where the second element is +the output (@pxref{Packages with Multiple Outputs}, for more on package +outputs). For example, the list below specifies three inputs: + +@lisp +(list libffi libunistring + `(,glib "bin")) ;the "bin" output of GLib +@end lisp + +In the example above, the @code{"out"} output of @code{libffi} and +@code{libunistring} is used. + +@quotation Compatibility Note +Until version 1.3.0, input lists were a list of tuples, +where each tuple has a label for the input (a string) as its first element, a package, origin, or derivation as its second element, and optionally the name of the output thereof that should be used, which -defaults to @code{"out"} (@pxref{Packages with Multiple Outputs}, for -more on package outputs). For example, the list below specifies three -inputs: +defaults to @code{"out"}. For example, the list below is equivalent to +the one above, but using the @dfn{old input style}: @lisp +;; Old input style (deprecated). `(("libffi" ,libffi) ("libunistring" ,libunistring) - ("glib:bin" ,glib "bin")) ;the "bin" output of Glib + ("glib:bin" ,glib "bin")) ;the "bin" output of GLib @end lisp +This style is now deprecated; it is still supported but support will be +removed in a future version. It should not be used for new package +definitions. +@end quotation + @cindex cross compilation, package dependencies The distinction between @code{native-inputs} and @code{inputs} is necessary when considering cross-compilation. When cross-compiling, @@ -6774,7 +6795,7 @@ cross-compiling: ;; When cross-compiled, Guile, for example, depends on ;; a native version of itself. Add it here. (native-inputs (if (%current-target-system) - `(("self" ,this-package)) + (list this-package) '()))) @end lisp @@ -7090,8 +7111,7 @@ depends on it: (name name) (version "3.0") ;; several fields omitted - (inputs - `(("lua" ,lua))) + (inputs (list lua)) (synopsis "Socket library for Lua"))) (define-public lua5.1-socket diff --git a/guix/packages.scm b/guix/packages.scm index a66dbea1b7..087e6e6a4a 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -366,6 +366,14 @@ name of its URI." ;; . (fold delete %supported-systems '("mips64el-linux" "powerpc-linux"))) +(define-inlinable (sanitize-inputs inputs) + "Sanitize INPUTS by turning it into a list of name/package tuples if it's +not already the case." + (cond ((null? inputs) inputs) + ((and (pair? (car inputs)) + (string? (caar inputs))) + inputs) + (else (map add-input-label inputs)))) ;; A package. (define-record-type* @@ -380,11 +388,14 @@ name of its URI." (default '()) (thunked)) (inputs package-inputs ; input packages or derivations - (default '()) (thunked)) + (default '()) (thunked) + (sanitize sanitize-inputs)) (propagated-inputs package-propagated-inputs ; same, but propagated - (default '()) (thunked)) + (default '()) (thunked) + (sanitize sanitize-inputs)) (native-inputs package-native-inputs ; native input packages/derivations - (default '()) (thunked)) + (default '()) (thunked) + (sanitize sanitize-inputs)) (outputs package-outputs ; list of strings (default '("out"))) @@ -415,6 +426,24 @@ name of its URI." source-properties->location)) (innate))) +(define (add-input-label input) + "Add an input label to INPUT." + (match input + ((? package? package) + (list (package-name package) package)) + (((? package? package) output) ;XXX: ugly? + (list (package-name package) package output)) + ((? gexp-input?) ;XXX: misplaced because 'native?' field is ignored? + (let ((obj (gexp-input-thing input)) + (output (gexp-input-output input))) + `(,(if (package? obj) + (package-name obj) + "_") + ,obj + ,@(if (string=? output "out") '() (list output))))) + (x + `("_" ,x)))) + (set-record-type-printer! (lambda (package port) (let ((loc (package-location package)) diff --git a/tests/packages.scm b/tests/packages.scm index 47d10af5bc..936aede4ff 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -137,7 +137,7 @@ ;; inputs. See . (let* ((dep (dummy-package "dep" (version "2"))) (old (dummy-package "foo" (version "1") - (propagated-inputs `(("dep" ,dep))))) + (propagated-inputs (list dep)))) (drv (package-derivation %store old)) (tx (mock ((gnu packages) find-best-packages-by-name (const (list old))) @@ -225,7 +225,7 @@ (bar (dummy-package "bar" (version "0") (replacement old))) (new (dummy-package "foo" (version "1") - (inputs `(("bar" ,bar))))) + (inputs (list bar)))) (tx (mock ((gnu packages) find-best-packages-by-name (const (list new))) (transaction-upgrade-entry @@ -275,13 +275,13 @@ (test-assert "package-transitive-inputs" (let* ((a (dummy-package "a")) (b (dummy-package "b" - (propagated-inputs `(("a" ,a))))) + (propagated-inputs (list a)))) (c (dummy-package "c" - (inputs `(("a" ,a))))) + (inputs (list a)))) (d (dummy-package "d" (propagated-inputs `(("x" "something.drv"))))) (e (dummy-package "e" - (inputs `(("b" ,b) ("c" ,c) ("d" ,d)))))) + (inputs (list b c d))))) (and (null? (package-transitive-inputs a)) (equal? `(("a" ,a)) (package-transitive-inputs b)) (equal? `(("a" ,a)) (package-transitive-inputs c)) @@ -327,19 +327,19 @@ (b (dummy-package "b" (build-system trivial-build-system) (supported-systems '("x" "y")) - (inputs `(("a" ,a))))) + (inputs (list a)))) (c (dummy-package "c" (build-system trivial-build-system) (supported-systems '("y" "z")) - (inputs `(("b" ,b))))) + (inputs (list b)))) (d (dummy-package "d" (build-system trivial-build-system) (supported-systems '("x" "y" "z")) - (inputs `(("b" ,b) ("c" ,c))))) + (inputs (list b c)))) (e (dummy-package "e" (build-system trivial-build-system) (supported-systems '("x" "y" "z")) - (inputs `(("d" ,d)))))) + (inputs (list d))))) (list (package-transitive-supported-systems a) (package-transitive-supported-systems b) (package-transitive-supported-systems c) @@ -355,13 +355,13 @@ (build-system trivial-build-system)))))) (let* ((a (dummy-package/no-implicit "a")) (b (dummy-package/no-implicit "b" - (propagated-inputs `(("a" ,a))))) + (propagated-inputs (list a)))) (c (dummy-package/no-implicit "c" - (inputs `(("a" ,a))))) + (inputs (list a)))) (d (dummy-package/no-implicit "d" - (native-inputs `(("b" ,b))))) + (native-inputs (list b)))) (e (dummy-package/no-implicit "e" - (inputs `(("c" ,c) ("d" ,d)))))) + (inputs (list c d))))) (lset= eq? (list a b c d e) (package-closure (list e)) @@ -384,12 +384,11 @@ (u (dummy-origin)) (i (dummy-origin)) (a (dummy-package "a")) - (b (dummy-package "b" - (inputs `(("a" ,a) ("i" ,i))))) + (b (dummy-package "b" (inputs (list a i)))) (c (package (inherit b) (source o))) (d (dummy-package "d" (build-system trivial-build-system) - (source u) (inputs `(("c" ,c)))))) + (source u) (inputs (list c))))) (test-assert "package-direct-sources, no source" (null? (package-direct-sources a))) (test-equal "package-direct-sources, #f source" @@ -457,7 +456,7 @@ (supported-systems '("x86_64-linux")))) (p (dummy-package "foo" (build-system gnu-build-system) - (inputs `(("d" ,d))) + (inputs (list d)) (supported-systems '("x86_64-linux" "armhf-linux"))))) (and (supported-package? p "x86_64-linux") (not (supported-package? p "i686-linux")) @@ -706,7 +705,7 @@ (test-assert "package-derivation, inputs deduplicated" (let* ((dep (dummy-package "dep")) - (p0 (dummy-package "p" (inputs `(("dep" ,dep))))) + (p0 (dummy-package "p" (inputs (list dep)))) (p1 (package (inherit p0) (inputs `(("dep" ,(package (inherit dep))) ,@(package-inputs p0)))))) @@ -755,7 +754,7 @@ (parameterize ((%graft? #f)) (let* ((dep (dummy-package "dep")) (p (dummy-package "p" - (inputs `(("dep" ,dep "non-existent")))))) + (inputs (list `(,dep "non-existent")))))) (guard (c ((derivation-missing-output-error? c) (and (string=? (derivation-missing-output c) "non-existent") (equal? (package-derivation %store dep) @@ -913,12 +912,12 @@ (p1 (dummy-package "p1" (native-search-paths (sp "PATH1")))) (p2 (dummy-package "p2" (native-search-paths (sp "PATH2")) - (inputs `(("p0" ,p0))) - (propagated-inputs `(("p1" ,p1))))) + (inputs (list p0)) + (propagated-inputs (list p1)))) (p3 (dummy-package "p3" (native-search-paths (sp "PATH3")) - (native-inputs `(("p0" ,p0))) - (propagated-inputs `(("p2" ,p2)))))) + (native-inputs (list p0)) + (propagated-inputs (list p2))))) (lset= string=? '("PATH1" "PATH2" "PATH3") (map search-path-specification-variable @@ -972,7 +971,7 @@ (dep* (package (inherit dep) (replacement new))) (dummy (dummy-package "dummy" (arguments '(#:implicit-inputs? #f)) - (inputs `(("dep" ,dep*)))))) + (inputs (list dep*))))) (equal? (package-grafts %store dummy) (list (graft (origin (package-derivation %store dep)) @@ -1004,11 +1003,11 @@ (dep (package (inherit new) (version "0.0"))) (dep* (package (inherit dep) (replacement new))) (prop (dummy-package "propagated" - (propagated-inputs `(("dep" ,dep*))) + (propagated-inputs (list dep*)) (arguments '(#:implicit-inputs? #f)))) (dummy (dummy-package "dummy" (arguments '(#:implicit-inputs? #f)) - (inputs `(("prop" ,prop)))))) + (inputs (list prop))))) (equal? (package-grafts %store dummy) (list (graft (origin (package-derivation %store dep)) @@ -1021,16 +1020,16 @@ (dep (package (inherit new) (version "0") (replacement new))) (p1 (dummy-package "intermediate1" (arguments '(#:implicit-inputs? #f)) - (inputs `(("dep" ,dep))))) + (inputs (list dep)))) (p2 (dummy-package "intermediate2" (arguments '(#:implicit-inputs? #f)) ;; Here we copy DEP to have an equivalent package that is not ;; 'eq?' to DEP. This is similar to what happens with ;; 'package-with-explicit-inputs' & co. - (inputs `(("dep" ,(package (inherit dep))))))) + (inputs (list (package (inherit dep)))))) (p3 (dummy-package "final" (arguments '(#:implicit-inputs? #f)) - (inputs `(("p1" ,p1) ("p2" ,p2)))))) + (inputs (list p1 p2))))) (equal? (package-grafts %store p3) (list (graft (origin (package-derivation %store @@ -1048,8 +1047,7 @@ (p0* (package (inherit p0) (version "1.1"))) (p1 (dummy-package "p1" (arguments '(#:implicit-inputs? #f)) - (inputs `(("p0" ,p0) - ("p0:lib" ,p0 "lib")))))) + (inputs (list p0 `(,p0 "lib")))))) (lset= equal? (pk (package-grafts %store p1)) (list (graft (origin (package-derivation %store p0)) @@ -1097,7 +1095,7 @@ #t))))) (p2r (dummy-package "P2" (build-system trivial-build-system) - (inputs `(("p1" ,p1))) + (inputs (list p1)) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out"))) @@ -1118,7 +1116,7 @@ #t))))) (p3 (dummy-package "p3" (build-system trivial-build-system) - (inputs `(("p2" ,p2))) + (inputs (list p2)) (arguments `(#:guile ,%bootstrap-guile #:builder (let ((out (assoc-ref %outputs "out"))) @@ -1187,7 +1185,7 @@ (lower lower))) (dep (dummy-package "dep" (build-system bs))) (pkg (dummy-package "example" - (native-inputs `(("dep" ,dep))))) + (native-inputs (list dep)))) (do-not-build (lambda (continue store lst . _) lst))) (equal? (with-build-handler do-not-build (parameterize ((%current-target-system "powerpc64le-linux-gnu") @@ -1214,9 +1212,9 @@ (test-assert "package->bag, propagated inputs" (let* ((dep (dummy-package "dep")) (prop (dummy-package "prop" - (propagated-inputs `(("dep" ,dep))))) + (propagated-inputs (list dep)))) (dummy (dummy-package "dummy" - (inputs `(("prop" ,prop))))) + (inputs (list prop)))) (inputs (bag-transitive-inputs (package->bag dummy #:graft? #f)))) (match (assoc "dep" inputs) (("dep" package) @@ -1229,7 +1227,7 @@ `(("libxml2" ,libxml2)) '())))) (pkg (dummy-package "foo" - (native-inputs `(("dep" ,dep))))) + (native-inputs (list dep)))) (bag (package->bag pkg (%current-system) "i586-gnu"))) (equal? (parameterize ((%current-system "x86_64-linux")) (bag-transitive-inputs bag)) @@ -1242,7 +1240,7 @@ `(("libxml2" ,libxml2)) '())))) (pkg (dummy-package "foo" - (native-inputs `(("dep" ,dep))))) + (native-inputs (list dep)))) (bag (package->bag pkg (%current-system) "foo86-hurd"))) (equal? (parameterize ((%current-target-system "foo64-gnu")) (bag-transitive-inputs bag)) @@ -1548,11 +1546,11 @@ (build-system trivial-build-system))) (glib (dummy-package "glib" (build-system trivial-build-system) - (propagated-inputs `(("libffi" ,libffi))))) + (propagated-inputs (list libffi)))) (gobject (dummy-package "gobject-introspection" (build-system trivial-build-system) - (inputs `(("glib" ,glib))) - (propagated-inputs `(("libffi" ,libffi))))) + (inputs (list glib)) + (propagated-inputs (list libffi)))) (rewrite (package-input-rewriting/spec `(("glib" . ,identity))))) (and (= (length (package-transitive-inputs gobject)) @@ -1569,11 +1567,11 @@ (build-system trivial-build-system))) (glib (dummy-package "glib" (build-system trivial-build-system) - (propagated-inputs `(("libffi" ,libffi))))) + (propagated-inputs (list libffi)))) (gobject (dummy-package "gobject-introspection" (build-system trivial-build-system) - (inputs `(("glib" ,glib))) - (propagated-inputs `(("libffi" ,libffi))))) + (inputs (list glib)) + (propagated-inputs (list libffi)))) (rewrite (package-input-rewriting `((,glib . ,glib))))) (and (= (length (package-transitive-inputs gobject)) (length (package-transitive-inputs (rewrite gobject)))) From patchwork Tue Jun 22 09:08:22 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 30621 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 6C6CF27BC81; Tue, 22 Jun 2021 10:09:26 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H2,SPF_HELO_PASS autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 16E5E27BC78 for ; Tue, 22 Jun 2021 10:09:26 +0100 (BST) Received: from localhost ([::1]:47110 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcPN-0000is-4x for patchwork@mira.cbaines.net; Tue, 22 Jun 2021 05:09:25 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:58904) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lvcP4-0008U0-Dk for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:06 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:54497) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcP1-00031q-Qe for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lvcP0-0007nN-Et for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#49169] [PATCH 03/11] lint: Add 'input-labels' checker. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 22 Jun 2021 09:09:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 49169 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 49169@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 49169-submit@debbugs.gnu.org id=B49169.162435293229896 (code B ref 49169); Tue, 22 Jun 2021 09:09:02 +0000 Received: (at 49169) by debbugs.gnu.org; 22 Jun 2021 09:08:52 +0000 Received: from localhost ([127.0.0.1]:37798 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcOp-0007m0-O7 for submit@debbugs.gnu.org; Tue, 22 Jun 2021 05:08:52 -0400 Received: from eggs.gnu.org ([209.51.188.92]:32832) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcOn-0007lH-9i for 49169@debbugs.gnu.org; Tue, 22 Jun 2021 05:08:49 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:52814) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcOh-0002nY-UB; Tue, 22 Jun 2021 05:08:43 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=49370 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcOh-0000B8-MV; Tue, 22 Jun 2021 05:08:43 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 22 Jun 2021 11:08:22 +0200 Message-Id: <20210622090830.15561-3-ludo@gnu.org> X-Mailer: git-send-email 2.32.0 In-Reply-To: <20210622090830.15561-1-ludo@gnu.org> References: <20210622090830.15561-1-ludo@gnu.org> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/lint.scm (check-input-labels): New procedure. (%local-checkers): Add 'input-labels' checker. * tests/lint.scm ("input labels: no warnings") ("input labels: one warning"): New tests. * doc/guix.texi (Invoking guix lint): Mention it. --- doc/guix.texi | 6 ++++++ guix/lint.scm | 36 ++++++++++++++++++++++++++++++++++++ tests/lint.scm | 14 ++++++++++++++ 3 files changed, 56 insertions(+) diff --git a/doc/guix.texi b/doc/guix.texi index 1a3ac85e58..5ff3898ff1 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -12114,6 +12114,12 @@ declare them as in this example: @item formatting Warn about obvious source code formatting issues: trailing white space, use of tabulations, etc. + +@item input-labels +Report old-style input labels that do not match the name of the +corresponding package. This aims to help migrate from the ``old input +style''. @xref{package Reference}, for more information on package +inputs and input styles. @end table The general syntax is: diff --git a/guix/lint.scm b/guix/lint.scm index 1bebfe03d3..7b73dffa19 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -77,6 +77,7 @@ #:export (check-description-style check-inputs-should-be-native check-inputs-should-not-be-an-input-at-all + check-input-labels check-patch-file-names check-patch-headers check-synopsis-style @@ -383,6 +384,37 @@ of a package, and INPUT-NAMES, a list of package specifications such as (package-input-intersection (package-direct-inputs package) input-names)))) +(define (check-input-labels package) + "Emit a warning for labels that differ from the corresponding package name." + (define (check input-kind package-inputs) + (define (warning label name) + (make-warning package + (G_ "label '~a' does not match package name '~a'") + (list label name) + #:field input-kind)) + + (append-map (match-lambda + (((? string? label) (? package? dependency)) + (if (string=? label (package-name dependency)) + '() + (list (warning label (package-name dependency))))) + (((? string? label) (? package? dependency) output) + (let ((expected (string-append (package-name dependency) + ":" output))) + (if (string=? label expected) + '() + (list (warning label expected))))) + (_ + '())) + (package-inputs package))) + + (append-map (match-lambda + ((kind proc) + (check kind proc))) + `((native-inputs ,package-native-inputs) + (inputs ,package-inputs) + (propagated-inputs ,package-propagated-inputs)))) + (define (package-name-regexp package) "Return a regexp that matches PACKAGE's name as a word at the beginning of a line." @@ -1493,6 +1525,10 @@ them for PACKAGE." (name 'inputs-should-not-be-input) (description "Identify inputs that shouldn't be inputs at all") (check check-inputs-should-not-be-an-input-at-all)) + (lint-checker + (name 'input-labels) + (description "Identify input labels that do not match package names") + (check check-input-labels)) (lint-checker (name 'license) ;; TRANSLATORS: is the name of a data type and must not be diff --git a/tests/lint.scm b/tests/lint.scm index 02ffb19d78..f247012c09 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -319,6 +319,20 @@ `(("python-setuptools" ,python-setuptools)))))) (check-inputs-should-not-be-an-input-at-all pkg)))) +(test-assert "input labels: no warnings" + (let ((pkg (dummy-package "x" + (inputs `(("glib" ,glib) + ("pkg-config" ,pkg-config)))))) + (null? (check-input-labels pkg)))) + +(test-equal "input labels: one warning" + "label 'pkgkonfig' does not match package name 'pkg-config'" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (inputs `(("glib" ,glib) + ("pkgkonfig" ,pkg-config)))))) + (check-input-labels pkg)))) + (test-equal "file patches: different file name -> warning" "file names of patches should start with the package name" (single-lint-warning-message From patchwork Tue Jun 22 09:08:23 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 30620 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id B016B27BC81; Tue, 22 Jun 2021 10:09:23 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H2,SPF_HELO_PASS autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 726CF27BC78 for ; Tue, 22 Jun 2021 10:09:23 +0100 (BST) Received: from localhost ([::1]:46862 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcPK-0000YJ-GQ for patchwork@mira.cbaines.net; Tue, 22 Jun 2021 05:09:22 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:58906) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lvcP4-0008U1-DH for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:06 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:54503) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcP1-00032X-Um for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lvcP1-0007np-PD for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#49169] [PATCH 04/11] packages: Add 'lookup-package-input' & co. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 22 Jun 2021 09:09:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 49169 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 49169@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 49169-submit@debbugs.gnu.org id=B49169.162435293529938 (code B ref 49169); Tue, 22 Jun 2021 09:09:03 +0000 Received: (at 49169) by debbugs.gnu.org; 22 Jun 2021 09:08:55 +0000 Received: from localhost ([127.0.0.1]:37807 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcOs-0007mj-RX for submit@debbugs.gnu.org; Tue, 22 Jun 2021 05:08:55 -0400 Received: from eggs.gnu.org ([209.51.188.92]:32836) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcOn-0007lJ-PX for 49169@debbugs.gnu.org; Tue, 22 Jun 2021 05:08:50 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:52816) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcOi-0002o4-KJ; Tue, 22 Jun 2021 05:08:44 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=49370 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcOi-0000B8-7m; Tue, 22 Jun 2021 05:08:44 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 22 Jun 2021 11:08:23 +0200 Message-Id: <20210622090830.15561-4-ludo@gnu.org> X-Mailer: git-send-email 2.32.0 In-Reply-To: <20210622090830.15561-1-ludo@gnu.org> References: <20210622090830.15561-1-ludo@gnu.org> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/packages.scm (lookup-input, lookup-package-input) (lookup-package-native-input, lookup-package-propagated-input) (lookup-package-direct-input): New procedures. * doc/guix.texi (package Reference): Document them. --- doc/guix.texi | 24 ++++++++++++++++++++++++ guix/packages.scm | 34 ++++++++++++++++++++++++++++++++++ 2 files changed, 58 insertions(+) diff --git a/doc/guix.texi b/doc/guix.texi index 5ff3898ff1..aeb0b2160a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6802,6 +6802,30 @@ cross-compiling: It is an error to refer to @code{this-package} outside a package definition. @end deffn +The following helper procedures are provided to help deal with package +inputs. + +@deffn {Scheme Procedure} lookup-package-input @var{package} @var{name} +@deffnx {Scheme Procedure} lookup-package-native-input @var{package} @var{name} +@deffnx {Scheme Procedure} lookup-package-propagated-input @var{package} @var{name} +@deffnx {Scheme Procedure} lookup-package-direct-input @var{package} @var{name} +Look up @var{name} among @var{package}'s inputs (or native, propagated, +or direct inputs). Return it if found, @code{#f} otherwise. + +@var{name} is the name of a package depended on. Here's how you might +use it: + +@lisp +(use-modules (guix packages) (gnu packages base)) + +(lookup-package-direct-input coreutils "gmp") +@result{} # +@end lisp + +In this example we obtain the @code{gmp} package that is among the +direct inputs of @code{coreutils}. +@end deffn + Because packages are regular Scheme objects that capture a complete dependency graph and associated build procedures, it is often useful to write procedures that take a package and return a modified version diff --git a/guix/packages.scm b/guix/packages.scm index 087e6e6a4a..c845026827 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -108,6 +108,11 @@ deprecated-package package-field-location + lookup-package-input + lookup-package-native-input + lookup-package-propagated-input + lookup-package-direct-input + package-direct-sources package-transitive-sources package-direct-inputs @@ -889,6 +894,35 @@ preserved, and only duplicate propagated inputs are removed." ((input rest ...) (loop rest (cons input result) propagated first? seen))))) +(define (lookup-input inputs name) + "Lookup NAME among INPUTS, an input list." + ;; Note: Currently INPUTS is assumed to be an input list that contains input + ;; labels. In the future, input labels will be gone and this procedure will + ;; check package names. + (match (assoc-ref inputs name) + ((obj) obj) + ((obj _) obj) + (#f #f))) + +(define (lookup-package-input package name) + "Look up NAME among PACKAGE's inputs. Return it if found, #f otherwise." + (lookup-input (package-inputs package) name)) + +(define (lookup-package-native-input package name) + "Look up NAME among PACKAGE's native inputs. Return it if found, #f +otherwise." + (lookup-input (package-native-inputs package) name)) + +(define (lookup-package-propagated-input package name) + "Look up NAME among PACKAGE's propagated inputs. Return it if found, #f +otherwise." + (lookup-input (package-propagated-inputs package) name)) + +(define (lookup-package-direct-input package name) + "Look up NAME among PACKAGE's direct inputs. Return it if found, #f +otherwise." + (lookup-input (package-direct-inputs package) name)) + (define (package-direct-sources package) "Return all source origins associated with PACKAGE; including origins in PACKAGE's inputs." From patchwork Tue Jun 22 09:08:24 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 30622 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 7D9B127BC81; Tue, 22 Jun 2021 10:09:32 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H2,SPF_HELO_PASS autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 1693727BC78 for ; Tue, 22 Jun 2021 10:09:32 +0100 (BST) Received: from localhost ([::1]:47692 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcPT-00017Q-3O for patchwork@mira.cbaines.net; Tue, 22 Jun 2021 05:09:31 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:58910) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lvcP4-0008UC-EQ for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:06 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:54504) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcP2-00032t-Gj for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:06 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lvcP2-0007nz-CA for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:04 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#49169] [PATCH 05/11] packages: Add 'modify-inputs'. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 22 Jun 2021 09:09:04 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 49169 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 49169@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 49169-submit@debbugs.gnu.org id=B49169.162435294329985 (code B ref 49169); Tue, 22 Jun 2021 09:09:04 +0000 Received: (at 49169) by debbugs.gnu.org; 22 Jun 2021 09:09:03 +0000 Received: from localhost ([127.0.0.1]:37810 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcP0-0007nM-Cd for submit@debbugs.gnu.org; Tue, 22 Jun 2021 05:09:02 -0400 Received: from eggs.gnu.org ([209.51.188.92]:32840) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcOo-0007lK-51 for 49169@debbugs.gnu.org; Tue, 22 Jun 2021 05:08:50 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:52818) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcOj-0002oj-0V; Tue, 22 Jun 2021 05:08:45 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=49370 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcOi-0000B8-PB; Tue, 22 Jun 2021 05:08:44 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 22 Jun 2021 11:08:24 +0200 Message-Id: <20210622090830.15561-5-ludo@gnu.org> X-Mailer: git-send-email 2.32.0 In-Reply-To: <20210622090830.15561-1-ludo@gnu.org> References: <20210622090830.15561-1-ludo@gnu.org> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/packages.scm (inputs-sans-labels, replace-input): New procedures. (prepend, replace, modify-inputs): New macros. * doc/guix.texi (Defining Package Variants): Document 'modify-inputs'. --- doc/guix.texi | 38 ++++++++++++++++++++------ guix/packages.scm | 68 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 98 insertions(+), 8 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index aeb0b2160a..b16a2c48a8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7105,20 +7105,42 @@ optional dependency, you can define a variant that removes that dependency like so: @lisp -(use-modules (gnu packages gdb) ;for 'gdb' - (srfi srfi-1)) ;for 'alist-delete' +(use-modules (gnu packages gdb)) ;for 'gdb' (define gdb-sans-guile (package (inherit gdb) - (inputs (alist-delete "guile" - (package-inputs gdb))))) + (inputs (modify-inputs (package-inputs gdb) + (delete "guile"))))) @end lisp -The @code{alist-delete} call above removes the tuple from the -@code{inputs} field that has @code{"guile"} as its first element -(@pxref{SRFI-1 Association Lists,,, guile, GNU Guile Reference -Manual}). +The @code{modify-inputs} form above removes the @code{"guile"} package +from the @code{inputs} field of @code{gdb}. The @code{modify-inputs} +macro is a helper that can prove useful anytime you want to remove, add, +or replace package inputs. + +@deffn {Scheme Syntax} modify-inputs @var{inputs} @var{clauses} +Modify the given package inputs, as returned by @code{package-inputs} & co., +according to the given clauses. The example below removes the GMP and ACL +inputs of Coreutils and adds libcap to the back of the input list: + +@lisp +(modify-inputs (package-inputs coreutils) + (delete "gmp" "acl") + (append libcap)) +@end lisp + +The example below replaces the @code{guile} package from the inputs of +@code{guile-redis} with @code{guile-2.2}: + +@lisp +(modify-inputs (package-inputs guile-redis) + (replace "guile" guile-2.2)) +@end lisp + +The last type of clause is @code{prepend}, to add inputs to the front of +the list. +@end deffn In some cases, you may find it useful to write functions (``procedures'', in Scheme parlance) that return a package based on some diff --git a/guix/packages.scm b/guix/packages.scm index c845026827..4ac1624ce2 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -55,6 +55,7 @@ #:re-export (%current-system %current-target-system search-path-specification) ;for convenience + #:re-export-and-replace (delete) ;used as syntactic keyword #:export (content-hash content-hash? content-hash-algorithm @@ -113,6 +114,10 @@ lookup-package-propagated-input lookup-package-direct-input + prepend ;syntactic keyword + replace ;syntactic keyword + modify-inputs + package-direct-sources package-transitive-sources package-direct-inputs @@ -923,6 +928,69 @@ otherwise." otherwise." (lookup-input (package-direct-inputs package) name)) +(define (inputs-sans-labels inputs) + "Return INPUTS stripped of any input labels." + (map (match-lambda + ((label obj) obj) + ((label obj output) `(,obj ,output))) + inputs)) + +(define (replace-input name replacement inputs) + "Replace input NAME by REPLACEMENT within INPUTS." + (map (lambda (input) + (match input + (((? string? label) . _) + (if (string=? label name) + (match replacement ;does REPLACEMENT specify an output? + ((_ _) (cons label replacement)) + (_ (list label replacement))) + input)))) + inputs)) + +(define-syntax prepend + (lambda (s) + (syntax-violation 'prepend + "'prepend' may only be used within 'modify-inputs'" + s))) + +(define-syntax replace + (lambda (s) + (syntax-violation 'replace + "'replace' may only be used within 'modify-inputs'" + s))) + +(define-syntax modify-inputs + (syntax-rules (delete prepend append replace) + "Modify the given package inputs, as returned by 'package-inputs' & co., +according to the given clauses. The example below removes the GMP and ACL +inputs of Coreutils and adds libcap: + + (modify-inputs (package-inputs coreutils) + (delete \"gmp\" \"acl\") + (append libcap)) + +Other types of clauses include 'prepend' and 'replace'." + ;; Note: This macro hides the fact that INPUTS, as returned by + ;; 'package-inputs' & co., is actually an alist with labels. Eventually, + ;; it will operate on list of inputs without labels. + ((_ inputs (delete name) clauses ...) + (modify-inputs (alist-delete name inputs) + clauses ...)) + ((_ inputs (delete names ...) clauses ...) + (modify-inputs (fold alist-delete inputs (list names ...)) + clauses ...)) + ((_ inputs (prepend lst ...) clauses ...) + (modify-inputs (append (list lst ...) (inputs-sans-labels inputs)) + clauses ...)) + ((_ inputs (append lst ...) clauses ...) + (modify-inputs (append (inputs-sans-labels inputs) (list lst ...)) + clauses ...)) + ((_ inputs (replace name replacement) clauses ...) + (modify-inputs (replace-input name replacement inputs) + clauses ...)) + ((_ inputs) + inputs))) + (define (package-direct-sources package) "Return all source origins associated with PACKAGE; including origins in PACKAGE's inputs." From patchwork Tue Jun 22 09:08:25 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 30627 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 2CBE627BC81; Tue, 22 Jun 2021 10:11:56 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H2,SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 57F6627BC78 for ; Tue, 22 Jun 2021 10:11:55 +0100 (BST) Received: from localhost ([::1]:54380 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcRm-0005k2-DU for patchwork@mira.cbaines.net; Tue, 22 Jun 2021 05:11:54 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:59182) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lvcPy-0002Yk-Np for guix-patches@gnu.org; Tue, 22 Jun 2021 05:10:02 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:54517) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcPy-0003gj-5I for guix-patches@gnu.org; Tue, 22 Jun 2021 05:10:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lvcPy-0007qN-0k for guix-patches@gnu.org; Tue, 22 Jun 2021 05:10:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#49169] [PATCH 06/11] gnu: Change inputs of core packages to plain lists. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 22 Jun 2021 09:10:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 49169 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 49169@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 49169-submit@debbugs.gnu.org id=B49169.162435294530022 (code B ref 49169); Tue, 22 Jun 2021 09:10:01 +0000 Received: (at 49169) by debbugs.gnu.org; 22 Jun 2021 09:09:05 +0000 Received: from localhost ([127.0.0.1]:37816 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcP1-0007nk-J9 for submit@debbugs.gnu.org; Tue, 22 Jun 2021 05:09:04 -0400 Received: from eggs.gnu.org ([209.51.188.92]:32850) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcOp-0007lO-Ca for 49169@debbugs.gnu.org; Tue, 22 Jun 2021 05:08:53 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:52820) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcOk-0002pr-38; Tue, 22 Jun 2021 05:08:46 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=49370 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcOj-0000B8-AT; Tue, 22 Jun 2021 05:08:45 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 22 Jun 2021 11:08:25 +0200 Message-Id: <20210622090830.15561-6-ludo@gnu.org> X-Mailer: git-send-email 2.32.0 In-Reply-To: <20210622090830.15561-1-ludo@gnu.org> References: <20210622090830.15561-1-ludo@gnu.org> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches This is transparent: the resulting derivations are unchanged. * gnu/packages/base.scm (grep, sed, tar, patch, diffutils, glibc/hurd-headers) (coreutils, gnu-make, make-glibc-utf8-locales): Change input fields to plain package lists and use 'modify-inputs'. * gnu/packages/guile.scm (guile-1.8, guile-json-1, guile-json-3) (guile-gdbm-ffi, guile-sqlite3, guile-bytestructures) (guile-git, guile-zlib, guile-lzlib, guile-zstd, guile-next): Likewise. * gnu/packages/mes.scm (nyacc-0.86, nyacc-0.99) (nyacc, nyacc-1.00.2, mes-0.19, mes, m2-planet): Likewise. --- gnu/packages/base.scm | 48 +++++++++---------- gnu/packages/guile.scm | 103 ++++++++++++----------------------------- gnu/packages/mes.scm | 25 ++++------ 3 files changed, 59 insertions(+), 117 deletions(-) diff --git a/gnu/packages/base.scm b/gnu/packages/base.scm index d30299a7b6..b0ba565d3b 100644 --- a/gnu/packages/base.scm +++ b/gnu/packages/base.scm @@ -109,8 +109,8 @@ command-line arguments, multiple languages, and so on.") "0gipv6bzkm1aihj0ncqpyh164xrzgcxcv9r1kwzyk2g1mzl1azk6")) (patches (search-patches "grep-timing-sensitive-test.patch")))) (build-system gnu-build-system) - (native-inputs `(("perl" ,perl))) ;some of the tests require it - (inputs `(("pcre" ,pcre))) + (native-inputs (list perl)) ;some of the tests require it + (inputs (list pcre)) (arguments `(#:phases (modify-phases %standard-phases @@ -161,8 +161,7 @@ including, for example, recursive directory searching.") (modules '((guix build utils))))) (build-system gnu-build-system) (synopsis "Stream editor") - (native-inputs - `(("perl" ,perl))) ;for tests + (native-inputs (list perl)) ;for tests (description "Sed is a non-interactive, text stream editor. It receives a text input from a file or from standard input and it then applies a series of text @@ -215,7 +214,7 @@ implementation offers several extensions over the standard utility.") ;; When cross-compiling, the 'set-shell-file-name' phase needs to be able ;; to refer to the target Bash. (inputs (if (%current-target-system) - `(("bash" ,bash)) + (list bash) '())) (synopsis "Managing tar archives") @@ -248,7 +247,7 @@ standard utility.") (if (%current-target-system) `(#:configure-flags '("gl_cv_func_working_mktime=yes")) '())) - (native-inputs `(("ed" ,ed))) + (native-inputs (list ed)) (synopsis "Apply differences to originals, with optional backups") (description "Patch is a program that applies changes to files based on differences @@ -271,7 +270,7 @@ differences.") (base32 "09isrg0isjinv8c535nxsi1s86wfdfzml80dbw41dj9x3hiad9xk")))) (build-system gnu-build-system) - (native-inputs `(("perl" ,perl))) + (native-inputs (list perl)) (synopsis "Comparing and merging files") (description "GNU Diffutils is a package containing tools for finding the @@ -330,16 +329,16 @@ used to apply commands with arbitrarily long arguments.") "1yjcrh5hw70c0yn8zw55pd6j51dj90anpq8mmg649ps9g3gdhn24")) (patches (search-patches "coreutils-ls.patch")))) (build-system gnu-build-system) - (inputs `(("acl" ,acl) ; TODO: add SELinux - ("attr" ,attr) ;for xattrs in ls, mv, etc - ("gmp" ,gmp) ;bignums in 'expr', yay! + (inputs `(,acl ;TODO: add SELinux + ,attr ;for xattrs in ls, mv, etc + ,gmp ;bignums in 'expr', yay! ;; Do not use libcap when cross-compiling since it's not quite ;; cross-compilable; and use it only for supported systems. ,@(if (and (not (%current-target-system)) (member (%current-system) (package-supported-systems libcap))) - `(("libcap" ,libcap)) ;capability support in 'ls', etc. + `(,libcap) ;capability support in 'ls', etc. '()))) (native-inputs ;; Perl is needed to run tests in native builds, and to run the bundled @@ -348,7 +347,7 @@ used to apply commands with arbitrarily long arguments.") ;; for help2man. (if (%current-target-system) '() - `(("perl" ,perl)))) + (list perl))) (outputs '("out" "debug")) (arguments `(#:parallel-build? #f ; help2man may be called too early @@ -443,8 +442,8 @@ standard.") "06cfqzpqsvdnsxbysl5p2fgdgxgl9y4p7scpnrfa8z2zgkjdspz0")) (patches (search-patches "make-impure-dirs.patch")))) (build-system gnu-build-system) - (native-inputs `(("pkg-config" ,pkg-config))) ; to detect Guile - (inputs `(("guile" ,guile-3.0))) + (native-inputs (list pkg-config)) ;to detect Guile + (inputs (list guile-3.0)) (outputs '("out" "debug")) (arguments `(,@(if (hurd-target?) @@ -1148,8 +1147,7 @@ to the @code{share/locale} sub-directory of this package.") locale ".UTF-8"))) ',locales) #t)))) - (native-inputs `(("glibc" ,glibc) - ("gzip" ,gzip))) + (native-inputs (list glibc gzip)) (synopsis (if default-locales? (P_ "Small sample of UTF-8 locales") (P_ "Customized sample of UTF-8 locales"))) @@ -1202,17 +1200,15 @@ command.") (package (inherit glibc) (name "glibc-hurd-headers") (outputs '("out")) - (propagated-inputs `(("gnumach-headers" ,gnumach-headers) - ("hurd-headers" ,hurd-headers))) + (propagated-inputs (list gnumach-headers hurd-headers)) (native-inputs - `(("mig" ,(if (%current-target-system) - ;; XXX: When targeting i586-pc-gnu, we need a 32-bit MiG, - ;; hence this hack. - (package - (inherit mig) - (arguments `(#:system "i686-linux"))) - mig)) - ,@(package-native-inputs glibc))) + (modify-inputs (package-native-inputs glibc) + (prepend (if (%current-target-system) + ;; XXX: When targeting i586-pc-gnu, we need a 32-bit MiG, + ;; hence this hack. + (package (inherit mig) + (arguments `(#:system "i686-linux"))) + mig)))) (arguments (substitute-keyword-arguments (package-arguments glibc) ;; We just pass the flags really needed to build the headers. diff --git a/gnu/packages/guile.scm b/gnu/packages/guile.scm index 68ee7bddf5..33736cdbc6 100644 --- a/gnu/packages/guile.scm +++ b/gnu/packages/guile.scm @@ -112,13 +112,11 @@ `(("self" ,this-package)) '())) - (inputs `(("gawk" ,gawk) - ("readline" ,readline))) + (inputs (list gawk readline)) ;; Since `guile-1.8.pc' has "Libs: ... -lgmp -lltdl", these must be ;; propagated. - (propagated-inputs `(("gmp" ,gmp) - ("libltdl" ,libltdl))) + (propagated-inputs (list gmp libltdl)) (native-search-paths (list (search-path-specification @@ -403,14 +401,14 @@ without requiring the source code to be rewritten.") (delete-file "test-suite/tests/version.test") #t)))))) (native-inputs - `(("autoconf" ,autoconf) - ("automake" ,automake) - ("libtool" ,libtool) - ("flex" ,flex) - ("gettext" ,gnu-gettext) - ("texinfo" ,texinfo) - ("gperf" ,gperf) - ,@(package-native-inputs guile-3.0))) + (modify-inputs (package-native-inputs guile-3.0) + (prepend autoconf + automake + libtool + flex + gnu-gettext + texinfo + gperf))) (synopsis "Development version of GNU Guile")))) (define* (make-guile-readline guile #:optional (name "guile-readline")) @@ -596,9 +594,8 @@ GNU@tie{}Guile. Use the @code{(ice-9 readline)} module and call its (build-system gnu-build-system) (arguments `(#:make-flags '("GUILE_AUTO_COMPILE=0"))) ;to prevent guild warnings - (native-inputs `(("pkg-config" ,pkg-config) - ("guile" ,guile-2.2))) - (inputs `(("guile" ,guile-2.2))) + (native-inputs (list pkg-config guile-2.2)) + (inputs (list guile-2.2)) (synopsis "JSON module for Guile") (description "Guile-JSON supports parsing and building JSON documents according to the @@ -636,9 +633,8 @@ specification. These are the main features: (sha256 (base32 "0nj0684qgh6ppkbdyxqfyjwsv2qbyairxpi8fzrhsi3xnc7jn4im")))) - (native-inputs `(("pkg-config" ,pkg-config) - ("guile" ,guile-3.0))) - (inputs `(("guile" ,guile-3.0))))) + (native-inputs (list pkg-config guile-3.0)) + (inputs (list guile-3.0)))) (define-public guile3.0-json (deprecated-package "guile3.0-json" guile-json-3)) @@ -697,10 +693,8 @@ specification. These are the main features: (format #f "(dynamic-link \"~a/lib/libgdbm.so\")" (assoc-ref inputs "gdbm")))) #t))))) - (native-inputs - `(("guile" ,guile-3.0))) - (inputs - `(("gdbm" ,gdbm))) + (native-inputs (list guile-3.0)) + (inputs (list gdbm)) (home-page "https://github.com/ijp/guile-gdbm") (synopsis "Guile bindings to the GDBM library via Guile's FFI") (description @@ -731,14 +725,8 @@ Guile's foreign function interface.") "1nryy9j3bk34i0alkmc9bmqsm0ayz92k1cdf752mvhyjjn8nr928")) (file-name (string-append name "-" version "-checkout")))) (build-system gnu-build-system) - (native-inputs - `(("autoconf" ,autoconf) - ("automake" ,automake) - ("guile" ,guile-3.0) - ("pkg-config" ,pkg-config))) - (inputs - `(("guile" ,guile-3.0) - ("sqlite" ,sqlite))) + (native-inputs (list autoconf automake guile-3.0 pkg-config)) + (inputs (list guile-3.0 sqlite)) (synopsis "Access SQLite databases from Guile") (description "This package provides Guile bindings to the SQLite database system.") @@ -778,13 +766,8 @@ Guile's foreign function interface.") (doc (string-append out "/share/doc/" package))) (install-file "README.md" doc) #t)))))) - (native-inputs - `(("autoconf" ,autoconf) - ("automake" ,automake) - ("pkg-config" ,pkg-config) - ("guile" ,guile-3.0))) - (inputs - `(("guile" ,guile-3.0))) + (native-inputs (list autoconf automake pkg-config guile-3.0)) + (inputs (list guile-3.0)) (synopsis "Structured access to bytevector contents for Guile") (description "Guile bytestructures offers a system imitating the type system @@ -821,17 +804,11 @@ type system, elevating types to first-class status.") (arguments `(#:make-flags '("GUILE_AUTO_COMPILE=0"))) ; to prevent guild warnings (native-inputs - `(("pkg-config" ,pkg-config) - ("autoconf" ,autoconf) - ("automake" ,automake) - ("texinfo" ,texinfo) - ("guile" ,guile-3.0) - ("guile-bytestructures" ,guile-bytestructures))) + (list pkg-config autoconf automake texinfo guile-3.0 guile-bytestructures)) (inputs - `(("guile" ,guile-3.0) - ("libgit2" ,libgit2))) + (list guile-3.0 libgit2)) (propagated-inputs - `(("guile-bytestructures" ,guile-bytestructures))) + (list guile-bytestructures)) (synopsis "Guile bindings for libgit2") (description "This package provides Guile bindings to libgit2, a library to @@ -868,16 +845,8 @@ manipulate repositories of the Git version control system.") (arguments '(#:make-flags '("GUILE_AUTO_COMPILE=0"))) ;to prevent guild warnings - (native-inputs - `(("autoconf" ,autoconf) - ("automake" ,automake) - ("pkg-config" ,pkg-config) - ,@(if (%current-target-system) - `(("guile" ,guile-3.0)) ;for 'guild compile' and 'guile-3.0.pc' - '()))) - (inputs - `(("guile" ,guile-3.0) - ("zlib" ,zlib))) + (native-inputs (list autoconf automake pkg-config guile-3.0)) + (inputs (list guile-3.0 zlib)) (synopsis "Guile bindings to zlib") (description "This package provides Guile bindings for zlib, a lossless @@ -907,16 +876,8 @@ Guile's foreign function interface.") (arguments '(#:make-flags '("GUILE_AUTO_COMPILE=0"))) ;to prevent guild warnings - (native-inputs - `(("autoconf" ,autoconf) - ("automake" ,automake) - ("pkg-config" ,pkg-config) - ,@(if (%current-target-system) - `(("guile" ,guile-3.0)) ;for 'guild compile' and 'guile-3.0.pc' - '()))) - (inputs - `(("guile" ,guile-3.0) - ("lzlib" ,lzlib))) + (native-inputs (list autoconf automake pkg-config guile-3.0)) + (inputs (list guile-3.0 lzlib)) (synopsis "Guile bindings to lzlib") (description "This package provides Guile bindings for lzlib, a C library for @@ -942,14 +903,8 @@ pure Scheme by using Guile's foreign function interface.") (base32 "1c8l7829b5yx8wdc0mrhzjfwb6h9hb7cd8dfxcr71a7vlsi86310")))) (build-system gnu-build-system) - (native-inputs - `(("autoconf" ,autoconf) - ("automake" ,automake) - ("pkg-config" ,pkg-config) - ("guile" ,guile-3.0))) - (inputs - `(("zstd" ,zstd "lib") - ("guile" ,guile-3.0))) + (native-inputs (list autoconf automake pkg-config guile-3.0)) + (inputs (list `(,zstd "lib") guile-3.0)) (synopsis "GNU Guile bindings to the zstd compression library") (description "This package provides a GNU Guile interface to the zstd (``zstandard'') diff --git a/gnu/packages/mes.scm b/gnu/packages/mes.scm index 750ec2e67a..bad4ce49b3 100644 --- a/gnu/packages/mes.scm +++ b/gnu/packages/mes.scm @@ -55,8 +55,7 @@ (base32 "0lkd9lyspvhxlfs0496gsllwinh62jk9wij6gpadvx9gwz6yavd9")))) (build-system gnu-build-system) - (native-inputs - `(("guile" ,guile-2.2))) + (native-inputs (list guile-2.2)) (synopsis "LALR(1) Parser Generator in Guile") (description "NYACC is an LALR(1) parser generator implemented in Guile. @@ -91,10 +90,8 @@ extensive examples, including parsers for the Javascript and C99 languages.") (("^DOCDIR =.*") "DOCDIR = @prefix@/share/doc/$(PACKAGE_TARNAME)\n")) #t)))) - (native-inputs - `(("pkg-config" ,pkg-config))) - (inputs - `(("guile" ,guile-2.2))))) + (native-inputs (list pkg-config)) + (inputs (list guile-2.2)))) (define-public nyacc (package @@ -115,8 +112,7 @@ extensive examples, including parsers for the Javascript and C99 languages.") "GUILE_GLOBAL_SITE=\ $prefix/share/guile/site/$GUILE_EFFECTIVE_VERSION\n")) #t)))) - (inputs - `(("guile" ,guile-3.0))))) + (inputs (list guile-3.0)))) (define-public nyacc-1.00.2 (package @@ -144,8 +140,7 @@ $prefix/share/guile/site/$GUILE_EFFECTIVE_VERSION\n")) (sha256 (base32 "065ksalfllbdrzl12dz9d9dcxrv97wqxblslngsc6kajvnvlyvpk")))) - (inputs - `(("guile" ,guile-2.2))))) + (inputs (list guile-2.2)))) (define-public mes-0.19 ;; Mes used for bootstrap. @@ -161,9 +156,7 @@ $prefix/share/guile/site/$GUILE_EFFECTIVE_VERSION\n")) "15h4yhaywdc0djpjlin2jz1kzahpqxfki0r0aav1qm9nxxmnp1l0")))) (build-system gnu-build-system) (supported-systems '("i686-linux" "x86_64-linux")) - (propagated-inputs - `(("mescc-tools" ,mescc-tools-0.5.2) - ("nyacc" ,nyacc-0.86))) + (propagated-inputs (list mescc-tools-0.5.2 nyacc-0.86)) (native-inputs `(("guile" ,guile-2.2) ,@(let ((target-system (or (%current-target-system) @@ -204,9 +197,7 @@ Guile.") (base32 "0mnryfkl0dwbr5gxp16j5s95gw7z1vm1fqa1pxabp0aiar1hw53s")))) (supported-systems '("armhf-linux" "i686-linux" "x86_64-linux")) - (propagated-inputs - `(("mescc-tools" ,mescc-tools) - ("nyacc" ,nyacc-1.00.2))) + (propagated-inputs (list mescc-tools nyacc-1.00.2)) (native-search-paths (list (search-path-specification (variable "C_INCLUDE_PATH") @@ -376,7 +367,7 @@ get_machine.") (base32 "0yyc0fcbbxi9jqa1n76x0rwspdrwmc8g09jlmsw9c35nflrhmz8q")))) (native-inputs - `(("mescc-tools" ,mescc-tools))) + (list mescc-tools)) (build-system gnu-build-system) (arguments `(#:make-flags (list (string-append "PREFIX=" (assoc-ref %outputs "out"))) From patchwork Tue Jun 22 09:08:26 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 30618 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id EA00727BC81; Tue, 22 Jun 2021 10:09:15 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H2,SPF_HELO_PASS autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 8601B27BC78 for ; Tue, 22 Jun 2021 10:09:15 +0100 (BST) Received: from localhost ([::1]:46190 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcPC-0008WL-I9 for patchwork@mira.cbaines.net; Tue, 22 Jun 2021 05:09:14 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:58908) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lvcP4-0008UB-DZ for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:06 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:54507) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcP3-00033O-6S for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:06 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lvcP2-0007o8-Uk for guix-patches@gnu.org; Tue, 22 Jun 2021 05:09:04 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#49169] [PATCH 07/11] utils: 'edit-expression' no longer leaks file ports. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 22 Jun 2021 09:09:04 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 49169 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 49169@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 49169-submit@debbugs.gnu.org id=B49169.162435294329995 (code B ref 49169); Tue, 22 Jun 2021 09:09:04 +0000 Received: (at 49169) by debbugs.gnu.org; 22 Jun 2021 09:09:03 +0000 Received: from localhost ([127.0.0.1]:37813 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcP1-0007nY-1U for submit@debbugs.gnu.org; Tue, 22 Jun 2021 05:09:03 -0400 Received: from eggs.gnu.org ([209.51.188.92]:32858) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcOq-0007lQ-08 for 49169@debbugs.gnu.org; Tue, 22 Jun 2021 05:08:52 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:52822) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcOk-0002q0-Kt; Tue, 22 Jun 2021 05:08:46 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=49370 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcOk-0000B8-DE; Tue, 22 Jun 2021 05:08:46 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 22 Jun 2021 11:08:26 +0200 Message-Id: <20210622090830.15561-7-ludo@gnu.org> X-Mailer: git-send-email 2.32.0 In-Reply-To: <20210622090830.15561-1-ludo@gnu.org> References: <20210622090830.15561-1-ludo@gnu.org> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/utils.scm (edit-expression): Use 'call-with-input-file' to make sure IN gets closed. --- guix/utils.scm | 64 ++++++++++++++++++++++++++------------------------ 1 file changed, 33 insertions(+), 31 deletions(-) diff --git a/guix/utils.scm b/guix/utils.scm index 19990ceb8a..a13b13c4fa 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -342,38 +342,40 @@ a list of command-line arguments passed to the compression program." be a procedure that takes the original expression in string and returns a new one. ENCODING will be used to interpret all port I/O, it default to UTF-8. This procedure returns #t on success." + (define file (assq-ref source-properties 'filename)) + (define line (assq-ref source-properties 'line)) + (define column (assq-ref source-properties 'column)) + (with-fluids ((%default-port-encoding encoding)) - (let* ((file (assq-ref source-properties 'filename)) - (line (assq-ref source-properties 'line)) - (column (assq-ref source-properties 'column)) - (in (open-input-file file)) - ;; The start byte position of the expression. - (start (begin (while (not (and (= line (port-line in)) - (= column (port-column in)))) - (when (eof-object? (read-char in)) - (error (format #f "~a: end of file~%" in)))) - (ftell in))) - ;; The end byte position of the expression. - (end (begin (read in) (ftell in)))) - (seek in 0 SEEK_SET) ; read from the beginning of the file. - (let* ((pre-bv (get-bytevector-n in start)) - ;; The expression in string form. - (str (iconv:bytevector->string - (get-bytevector-n in (- end start)) - (port-encoding in))) - (post-bv (get-bytevector-all in)) - (str* (proc str))) - ;; Verify the edited expression is still a scheme expression. - (call-with-input-string str* read) - ;; Update the file with edited expression. - (with-atomic-file-output file - (lambda (out) - (put-bytevector out pre-bv) - (display str* out) - ;; post-bv maybe the end-of-file object. - (when (not (eof-object? post-bv)) - (put-bytevector out post-bv)) - #t)))))) + (call-with-input-file file + (lambda (in) + (let* ( ;; The start byte position of the expression. + (start (begin (while (not (and (= line (port-line in)) + (= column (port-column in)))) + (when (eof-object? (read-char in)) + (error (format #f "~a: end of file~%" in)))) + (ftell in))) + ;; The end byte position of the expression. + (end (begin (read in) (ftell in)))) + (seek in 0 SEEK_SET) ; read from the beginning of the file. + (let* ((pre-bv (get-bytevector-n in start)) + ;; The expression in string form. + (str (iconv:bytevector->string + (get-bytevector-n in (- end start)) + (port-encoding in))) + (post-bv (get-bytevector-all in)) + (str* (proc str))) + ;; Verify the edited expression is still a scheme expression. + (call-with-input-string str* read) + ;; Update the file with edited expression. + (with-atomic-file-output file + (lambda (out) + (put-bytevector out pre-bv) + (display str* out) + ;; post-bv maybe the end-of-file object. + (when (not (eof-object? post-bv)) + (put-bytevector out post-bv)) + #t)))))))) ;;; From patchwork Tue Jun 22 09:08:27 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 30624 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 0E4B627BC81; Tue, 22 Jun 2021 10:10:31 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H2,SPF_HELO_PASS autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id A974527BC78 for ; Tue, 22 Jun 2021 10:10:30 +0100 (BST) Received: from localhost ([::1]:50606 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcQP-000359-Pc for patchwork@mira.cbaines.net; Tue, 22 Jun 2021 05:10:29 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:59190) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lvcQ0-0002aC-Of for guix-patches@gnu.org; Tue, 22 Jun 2021 05:10:05 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:54519) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcPy-0003hd-WF for guix-patches@gnu.org; Tue, 22 Jun 2021 05:10:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lvcPy-0007qc-Ro for guix-patches@gnu.org; Tue, 22 Jun 2021 05:10:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#49169] [PATCH 08/11] utils: Add 'go-to-location' with source location caching. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 22 Jun 2021 09:10:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 49169 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 49169@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 49169-submit@debbugs.gnu.org id=B49169.162435294530051 (code B ref 49169); Tue, 22 Jun 2021 09:10:02 +0000 Received: (at 49169) by debbugs.gnu.org; 22 Jun 2021 09:09:05 +0000 Received: from localhost ([127.0.0.1]:37823 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcP3-0007oL-8h for submit@debbugs.gnu.org; Tue, 22 Jun 2021 05:09:05 -0400 Received: from eggs.gnu.org ([209.51.188.92]:32866) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcOq-0007lR-BZ for 49169@debbugs.gnu.org; Tue, 22 Jun 2021 05:08:53 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:52824) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcOl-0002qD-6N; Tue, 22 Jun 2021 05:08:47 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=49370 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcOk-0000B8-Ut; Tue, 22 Jun 2021 05:08:47 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 22 Jun 2021 11:08:27 +0200 Message-Id: <20210622090830.15561-8-ludo@gnu.org> X-Mailer: git-send-email 2.32.0 In-Reply-To: <20210622090830.15561-1-ludo@gnu.org> References: <20210622090830.15561-1-ludo@gnu.org> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/utils.scm (%source-location-map): New variable. (go-to-location): New procedure. (edit-expression): Use it instead of custom loop. * guix/packages.scm (package-field-location)[goto]: Remove. Use 'go-to-location' instead of 'goto'. --- guix/packages.scm | 8 +----- guix/utils.scm | 66 ++++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 63 insertions(+), 11 deletions(-) diff --git a/guix/packages.scm b/guix/packages.scm index 4ac1624ce2..d15a17edc0 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -514,12 +514,6 @@ object." (define (package-field-location package field) "Return the source code location of the definition of FIELD for PACKAGE, or #f if it could not be determined." - (define (goto port line column) - (unless (and (= (port-column port) (- column 1)) - (= (port-line port) (- line 1))) - (unless (eof-object? (read-char port)) - (goto port line column)))) - (match (package-location package) (($ file line column) (match (search-path %load-path file) @@ -529,7 +523,7 @@ object." ;; In general we want to keep relative file names for modules. (call-with-input-file file-found (lambda (port) - (goto port line column) + (go-to-location port line column) (match (read port) (('package inits ...) (let ((field (assoc field inits))) diff --git a/guix/utils.scm b/guix/utils.scm index a13b13c4fa..f8f6672bb1 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -49,6 +49,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module ((ice-9 iconv) #:prefix iconv:) + #:use-module (ice-9 vlist) #:autoload (zlib) (make-zlib-input-port make-zlib-output-port) #:use-module (system foreign) #:re-export ( ;for backwards compatibility @@ -117,6 +118,7 @@ cache-directory readlink* + go-to-location edit-expression filtered-port @@ -337,6 +339,65 @@ a list of command-line arguments passed to the compression program." (unless (every (compose zero? cdr waitpid) pids) (error "compressed-output-port failure" pids)))))) +(define %source-location-map + ;; Maps inode/device tuples to "source location maps" used by + ;; 'go-to-location'. + (make-hash-table)) + +(define (go-to-location port line column) + "Jump to LINE and COLUMN (both one-indexed) in PORT. Maintain a source +location map such that this can boil down to seek(2) and a few read(2) calls, +which can drastically speed up repetitive operations on large files." + (let* ((stat (stat port)) + (key (list (stat:ino stat) (stat:dev stat))) + (stamp (list (stat:mtime stat) (stat:mtimensec stat) + (stat:size stat))) + + ;; Look for an up-to-date source map for KEY. The map is a vlist + ;; where each entry gives the byte offset of the beginning of a line: + ;; element 0 is the offset of the first line, element 1 the offset of + ;; the second line, etc. The map is filled lazily. + (source-map (match (hash-ref %source-location-map key) + (#f + (vlist-cons 0 vlist-null)) + ((cache-stamp ... map) + (if (equal? cache-stamp stamp) ;invalidate? + map + (vlist-cons 0 vlist-null))))) + (last (vlist-length source-map))) + ;; Jump to LINE, ideally via SOURCE-MAP. + (if (<= line last) + (seek port (vlist-ref source-map (- line 1)) SEEK_SET) + (let ((target line) + (offset (vlist-ref source-map (- last 1)))) + (seek port offset SEEK_SET) + (let loop ((source-map (vlist-reverse source-map)) + (line last)) + (if (< line target) + (match (read-char port) + (#\newline + (loop (vlist-cons (ftell port) source-map) + (+ 1 line))) + ((? eof-object?) + (error "unexpected end of file" port line)) + (chr (loop source-map line))) + (hash-set! %source-location-map key + `(,@stamp + ,(vlist-reverse source-map))))))) + + ;; Read up to COLUMN. + (let ((target column)) + (let loop ((column 1)) + (when (< column target) + (match (read-char port) + (#\newline (error "unexpected end of line" port)) + (#\tab (loop (+ 8 column))) + (chr (loop (+ 1 column))))))) + + ;; Update PORT's position info. + (set-port-line! port (- line 1)) + (set-port-column! port (- column 1)))) + (define* (edit-expression source-properties proc #:key (encoding "UTF-8")) "Edit the expression specified by SOURCE-PROPERTIES using PROC, which should be a procedure that takes the original expression in string and returns a new @@ -350,10 +411,7 @@ This procedure returns #t on success." (call-with-input-file file (lambda (in) (let* ( ;; The start byte position of the expression. - (start (begin (while (not (and (= line (port-line in)) - (= column (port-column in)))) - (when (eof-object? (read-char in)) - (error (format #f "~a: end of file~%" in)))) + (start (begin (go-to-location in (+ 1 line) (+ 1 column)) (ftell in))) ;; The end byte position of the expression. (end (begin (read in) (ftell in)))) From patchwork Tue Jun 22 09:08:28 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 30623 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 12F0027BC78; Tue, 22 Jun 2021 10:10:18 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H2,SPF_HELO_PASS autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id C63EF27BC81 for ; Tue, 22 Jun 2021 10:10:15 +0100 (BST) Received: from localhost ([::1]:49922 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcQA-0002by-RE for patchwork@mira.cbaines.net; Tue, 22 Jun 2021 05:10:14 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:59184) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lvcPy-0002Z4-R1 for guix-patches@gnu.org; Tue, 22 Jun 2021 05:10:02 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:54518) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcPy-0003hD-IL for guix-patches@gnu.org; Tue, 22 Jun 2021 05:10:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lvcPy-0007qU-EY for guix-patches@gnu.org; Tue, 22 Jun 2021 05:10:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#49169] [PATCH 09/11] utils: 'edit-expression' modifies the file only if necessary. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 22 Jun 2021 09:10:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 49169 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 49169@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 49169-submit@debbugs.gnu.org id=B49169.162435294530032 (code B ref 49169); Tue, 22 Jun 2021 09:10:02 +0000 Received: (at 49169) by debbugs.gnu.org; 22 Jun 2021 09:09:05 +0000 Received: from localhost ([127.0.0.1]:37820 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcP2-0007o9-TX for submit@debbugs.gnu.org; Tue, 22 Jun 2021 05:09:05 -0400 Received: from eggs.gnu.org ([209.51.188.92]:32876) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcOq-0007lT-Tt for 49169@debbugs.gnu.org; Tue, 22 Jun 2021 05:08:53 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:52828) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcOl-0002r5-Nz; Tue, 22 Jun 2021 05:08:47 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=49370 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcOl-0000B8-GR; Tue, 22 Jun 2021 05:08:47 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 22 Jun 2021 11:08:28 +0200 Message-Id: <20210622090830.15561-9-ludo@gnu.org> X-Mailer: git-send-email 2.32.0 In-Reply-To: <20210622090830.15561-1-ludo@gnu.org> References: <20210622090830.15561-1-ludo@gnu.org> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/utils.scm (edit-expression): Check whether STR* equals STR. --- guix/utils.scm | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/guix/utils.scm b/guix/utils.scm index f8f6672bb1..e6d0761679 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -423,17 +423,19 @@ This procedure returns #t on success." (port-encoding in))) (post-bv (get-bytevector-all in)) (str* (proc str))) - ;; Verify the edited expression is still a scheme expression. - (call-with-input-string str* read) - ;; Update the file with edited expression. - (with-atomic-file-output file - (lambda (out) - (put-bytevector out pre-bv) - (display str* out) - ;; post-bv maybe the end-of-file object. - (when (not (eof-object? post-bv)) - (put-bytevector out post-bv)) - #t)))))))) + ;; Modify FILE only if there are changes. + (unless (string=? str* str) + ;; Verify the edited expression is still a scheme expression. + (call-with-input-string str* read) + ;; Update the file with edited expression. + (with-atomic-file-output file + (lambda (out) + (put-bytevector out pre-bv) + (display str* out) + ;; post-bv maybe the end-of-file object. + (when (not (eof-object? post-bv)) + (put-bytevector out post-bv)) + #t))))))))) ;;; From patchwork Tue Jun 22 09:08:29 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 30628 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 17F0E27BC81; Tue, 22 Jun 2021 10:12:21 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H2,SPF_HELO_PASS autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id D291A27BC78 for ; Tue, 22 Jun 2021 10:12:20 +0100 (BST) Received: from localhost ([::1]:54592 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcSB-00060V-UI for patchwork@mira.cbaines.net; Tue, 22 Jun 2021 05:12:19 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:59188) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lvcQ0-0002aB-Nv for guix-patches@gnu.org; Tue, 22 Jun 2021 05:10:05 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:54520) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcPz-0003hy-DU for guix-patches@gnu.org; Tue, 22 Jun 2021 05:10:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lvcPz-0007qj-91 for guix-patches@gnu.org; Tue, 22 Jun 2021 05:10:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#49169] [PATCH 10/11] utils: 'edit-expression' copies part of the original source map. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 22 Jun 2021 09:10:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 49169 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 49169@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 49169-submit@debbugs.gnu.org id=B49169.162435294630058 (code B ref 49169); Tue, 22 Jun 2021 09:10:03 +0000 Received: (at 49169) by debbugs.gnu.org; 22 Jun 2021 09:09:06 +0000 Received: from localhost ([127.0.0.1]:37825 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcP3-0007od-Qb for submit@debbugs.gnu.org; Tue, 22 Jun 2021 05:09:06 -0400 Received: from eggs.gnu.org ([209.51.188.92]:32884) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcOr-0007lU-IP for 49169@debbugs.gnu.org; Tue, 22 Jun 2021 05:08:54 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:52830) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcOm-0002rn-8x; Tue, 22 Jun 2021 05:08:48 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=49370 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcOm-0000B8-1j; Tue, 22 Jun 2021 05:08:48 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 22 Jun 2021 11:08:29 +0200 Message-Id: <20210622090830.15561-10-ludo@gnu.org> X-Mailer: git-send-email 2.32.0 In-Reply-To: <20210622090830.15561-1-ludo@gnu.org> References: <20210622090830.15561-1-ludo@gnu.org> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/utils.scm (source-location-key/stamp): New procedure. (go-to-location): Use it. (move-source-location-map!): New procedure. (edit-expression): Call it. --- guix/utils.scm | 37 ++++++++++++++++++++++++++++++++----- 1 file changed, 32 insertions(+), 5 deletions(-) diff --git a/guix/utils.scm b/guix/utils.scm index e6d0761679..65d709a01f 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -34,6 +34,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-39) + #:use-module (srfi srfi-71) #:use-module (ice-9 ftw) #:use-module (rnrs io ports) ;need 'port-position' etc. #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) @@ -344,14 +345,20 @@ a list of command-line arguments passed to the compression program." ;; 'go-to-location'. (make-hash-table)) -(define (go-to-location port line column) +(define (source-location-key/stamp stat) + "Return two values: the key for STAT in %SOURCE-LOCATION-MAP, and a stamp +used to invalidate corresponding entries." + (let ((key (list (stat:ino stat) (stat:dev stat))) + (stamp (list (stat:mtime stat) (stat:mtimensec stat) + (stat:size stat)))) + (values key stamp))) + +(define* (go-to-location port line column) "Jump to LINE and COLUMN (both one-indexed) in PORT. Maintain a source location map such that this can boil down to seek(2) and a few read(2) calls, which can drastically speed up repetitive operations on large files." (let* ((stat (stat port)) - (key (list (stat:ino stat) (stat:dev stat))) - (stamp (list (stat:mtime stat) (stat:mtimensec stat) - (stat:size stat))) + (key stamp (source-location-key/stamp stat)) ;; Look for an up-to-date source map for KEY. The map is a vlist ;; where each entry gives the byte offset of the beginning of a line: @@ -398,6 +405,20 @@ which can drastically speed up repetitive operations on large files." (set-port-line! port (- line 1)) (set-port-column! port (- column 1)))) +(define (move-source-location-map! source target line) + "Move the source location map from SOURCE up to LINE to TARGET. SOURCE and +TARGET must be stat buffers as returned by 'stat'." + (let* ((source-key (source-location-key/stamp source)) + (target-key target-stamp (source-location-key/stamp target))) + (match (hash-ref %source-location-map source-key) + (#f #t) + ((_ ... source-map) + ;; Strip the source map and update the associated stamp. + (let ((source-map (vlist-take source-map (max line 1)))) + (hash-remove! %source-location-map source-key) + (hash-set! %source-location-map target-key + `(,@target-stamp ,source-map))))))) + (define* (edit-expression source-properties proc #:key (encoding "UTF-8")) "Edit the expression specified by SOURCE-PROPERTIES using PROC, which should be a procedure that takes the original expression in string and returns a new @@ -435,7 +456,13 @@ This procedure returns #t on success." ;; post-bv maybe the end-of-file object. (when (not (eof-object? post-bv)) (put-bytevector out post-bv)) - #t))))))))) + #t)) + + ;; Due to 'with-atomic-file-output', IN and FILE no longer share + ;; the same inode, but we can reassign the source map up to LINE + ;; to the new file. + (move-source-location-map! (stat in) (stat file) + (+ 1 line))))))))) ;;; From patchwork Tue Jun 22 09:08:30 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 30625 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 0CEF127BC81; Tue, 22 Jun 2021 10:10:59 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H2,SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 6DBE427BC78 for ; Tue, 22 Jun 2021 10:10:57 +0100 (BST) Received: from localhost ([::1]:51236 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcQq-0003YM-FW for patchwork@mira.cbaines.net; Tue, 22 Jun 2021 05:10:56 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:59186) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lvcQ0-0002aA-O3 for guix-patches@gnu.org; Tue, 22 Jun 2021 05:10:05 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:54521) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcPz-0003hz-Qe for guix-patches@gnu.org; Tue, 22 Jun 2021 05:10:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lvcPz-0007qr-Md for guix-patches@gnu.org; Tue, 22 Jun 2021 05:10:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#49169] [PATCH 11/11] Add 'guix style'. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 22 Jun 2021 09:10:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 49169 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 49169@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 49169-submit@debbugs.gnu.org id=B49169.162435294730066 (code B ref 49169); Tue, 22 Jun 2021 09:10:03 +0000 Received: (at 49169) by debbugs.gnu.org; 22 Jun 2021 09:09:07 +0000 Received: from localhost ([127.0.0.1]:37827 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcP4-0007ol-9B for submit@debbugs.gnu.org; Tue, 22 Jun 2021 05:09:07 -0400 Received: from eggs.gnu.org ([209.51.188.92]:32888) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvcOs-0007lX-2E for 49169@debbugs.gnu.org; Tue, 22 Jun 2021 05:08:56 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:52832) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvcOm-0002sb-Qc; Tue, 22 Jun 2021 05:08:48 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=49370 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvcOm-0000B8-Iz; Tue, 22 Jun 2021 05:08:48 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Tue, 22 Jun 2021 11:08:30 +0200 Message-Id: <20210622090830.15561-11-ludo@gnu.org> X-Mailer: git-send-email 2.32.0 In-Reply-To: <20210622090830.15561-1-ludo@gnu.org> References: <20210622090830.15561-1-ludo@gnu.org> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/scripts/style.scm, tests/style.scm: New files. * Makefile.am (MODULES, SCM_TESTS): Add them. * po/guix/POTFILES.in: Add 'guix/scripts/style.scm'. * doc/guix.texi (Invoking guix style): New node. (package Reference): Reference it. (Invoking guix lint): Likewise. --- Makefile.am | 2 + doc/guix.texi | 66 +++++- guix/scripts/style.scm | 475 +++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 1 + tests/style.scm | 328 ++++++++++++++++++++++++++++ 5 files changed, 870 insertions(+), 2 deletions(-) create mode 100644 guix/scripts/style.scm create mode 100644 tests/style.scm diff --git a/Makefile.am b/Makefile.am index a10e06e5a7..d2eb60ecd6 100644 --- a/Makefile.am +++ b/Makefile.am @@ -285,6 +285,7 @@ MODULES = \ guix/scripts/refresh.scm \ guix/scripts/repl.scm \ guix/scripts/describe.scm \ + guix/scripts/style.scm \ guix/scripts/system.scm \ guix/scripts/system/search.scm \ guix/scripts/system/reconfigure.scm \ @@ -497,6 +498,7 @@ SCM_TESTS = \ tests/swh.scm \ tests/syscalls.scm \ tests/system.scm \ + tests/style.scm \ tests/texlive.scm \ tests/transformations.scm \ tests/ui.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index b16a2c48a8..e1fd43201d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -284,6 +284,7 @@ Utilities * Invoking guix hash:: Computing the cryptographic hash of a file. * Invoking guix import:: Importing package definitions. * Invoking guix refresh:: Updating package definitions. +* Invoking guix style:: Styling package definitions. * Invoking guix lint:: Finding errors in package definitions. * Invoking guix size:: Profiling disk usage. * Invoking guix graph:: Visualizing the graph of packages. @@ -6707,7 +6708,8 @@ the one above, but using the @dfn{old input style}: This style is now deprecated; it is still supported but support will be removed in a future version. It should not be used for new package -definitions. +definitions. @xref{Invoking guix style}, on how to migrate to the new +style. @end quotation @cindex cross compilation, package dependencies @@ -10234,6 +10236,7 @@ the Scheme programming interface of Guix in a convenient way. * Invoking guix hash:: Computing the cryptographic hash of a file. * Invoking guix import:: Importing package definitions. * Invoking guix refresh:: Updating package definitions. +* Invoking guix style:: Styling package definitions. * Invoking guix lint:: Finding errors in package definitions. * Invoking guix size:: Profiling disk usage. * Invoking guix graph:: Visualizing the graph of packages. @@ -12032,6 +12035,64 @@ token procured from @uref{https://github.com/settings/tokens} or otherwise. +@node Invoking guix style +@section Invoking @command{guix style} + +The @command{guix style} command helps packagers style their package +definitions according to the latest fashionable trends. The command +currently focuses on one aspect: the style of package inputs. It may +eventually be extended to handle other stylistic matters. + +The way package inputs are written is going through a transition +(@pxref{package Reference}, for more on package inputs). Until version +1.3.0, package inputs were written using the ``old style'', where each +input was given an explicit label, most of the time the package name: + +@lisp +(package + ;; @dots{} + ;; The "old style" (deprecated). + (inputs `(("libunistring" ,libunistring) + ("libffi" ,libffi)))) +@end lisp + +Today, the old style is deprecated and the preferred style looks like +this: + +@lisp +(package + ;; @dots{} + ;; The "new style". + (inputs (list libunistring libffi))) +@end lisp + +Likewise, uses of @code{alist-delete} and friends to manipulate inputs +is now deprecated in favor of @code{modify-inputs} (@pxref{Defining +Package Variants}, for more info on @code{modify-inputs}). + +In the vast majority of cases, this is a purely mechanical change on the +surface syntax that does not even incur a package rebuild. Running +@command{guix style} can do that for you, whether you're working on +packages in Guix proper or in an external channel. + +The general syntax is: + +@example +guix style [@var{options}] @var{package}@dots{} +@end example + +This causes @command{guix style} to analyze and rewrite the definition +of @var{package}@dots{}. It does so in a conservative way: preserving +comments and bailing out if it cannot make sense of the code that +appears in an inputs field. The available options are listed below. + +@table @code +@item --load-path=@var{directory} +@itemx -L @var{directory} +Add @var{directory} to the front of the package module search path +(@pxref{Package Modules}). +@end table + @node Invoking guix lint @section Invoking @command{guix lint} @@ -12165,7 +12226,8 @@ use of tabulations, etc. Report old-style input labels that do not match the name of the corresponding package. This aims to help migrate from the ``old input style''. @xref{package Reference}, for more information on package -inputs and input styles. +inputs and input styles. @xref{Invoking guix style}, on how to migrate +to the new style. @end table The general syntax is: diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm new file mode 100644 index 0000000000..c75b86081e --- /dev/null +++ b/guix/scripts/style.scm @@ -0,0 +1,475 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 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 . + +;;; Commentary: +;;; +;;; This script updates package definitions so they use the "simplified" style +;;; for input lists, as in: +;;; +;;; (package +;;; ;; ... +;;; (inputs (list foo bar baz))) +;;; +;;; Code: + +(define-module (guix scripts style) + #:autoload (gnu packages) (specification->package fold-packages) + #:use-module (guix scripts) + #:use-module ((guix scripts build) #:select (%standard-build-options)) + #:use-module (guix combinators) + #:use-module (guix ui) + #:use-module (guix packages) + #:use-module (guix utils) + #:use-module (guix i18n) + #:use-module (guix diagnostics) + #:use-module (ice-9 control) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-style)) + + +;;; +;;; Comment-preserving reader. +;;; + +;; A comment. +(define-record-type + (comment str margin?) + comment? + (str comment->string) + (margin? comment-margin?)) + +(define (read-with-comments port) + "Like 'read', but include objects when they're encountered." + ;; Note: Instead of implementing this functionality in 'read' proper, which + ;; is the best approach long-term, this code is a later on top of 'read', + ;; such that we don't have to rely on a specific Guile version. + (let loop ((blank-line? #t) + (return (const 'unbalanced))) + (match (read-char port) + ((? eof-object? eof) + eof) ;oops! + (chr + (cond ((eqv? chr #\newline) + (loop #t return)) + ((char-set-contains? char-set:whitespace chr) + (loop blank-line? return)) + ((memv chr '(#\( #\[)) + (let/ec return + (let liip ((lst '())) + (liip (cons (loop #f (lambda () + (return (reverse lst)))) + lst))))) + ((memv chr '(#\) #\])) + (return)) + ((eq? chr #\') + (list 'quote (loop #f return))) + ((eq? chr #\`) + (list 'quasiquote (loop #f return))) + ((eq? chr #\,) + (list (match (peek-char port) + (#\@ + (read-char port) + 'unquote-splicing) + (_ + 'unquote)) + (loop #f return))) + ((eqv? chr #\;) + (unread-char chr port) + (comment (read-line port 'concat) + (not blank-line?))) + (else + (unread-char chr port) + (read port))))))) + + +;;; +;;; Comment-preserving pretty-printer. +;;; + +(define* (pretty-print-with-comments port obj + #:key + (indent 0) + (max-width 78) + (long-list 5)) + (let loop ((indent indent) + (column indent) + (delimited? #t) ;true if comes after a delimiter + (obj obj)) + (match obj + ((? comment? comment) + (if (comment-margin? comment) + (begin + (display " " port) + (display (comment->string comment) port)) + (begin + (newline port) + (display (make-string indent #\space) port) + (display (comment->string comment) port))) + (display (make-string indent #\space) port) + indent) + (('quote lst) + (unless delimited? (display " " port)) + (display "'" port) + (loop indent (+ column (if delimited? 1 2)) #t lst)) + (('quasiquote lst) + (unless delimited? (display " " port)) + (display "`" port) + (loop indent (+ column (if delimited? 1 2)) #t lst)) + (('unquote lst) + (unless delimited? (display " " port)) + (display "," port) + (loop indent (+ column (if delimited? 1 2)) #t lst)) + (('modify-inputs inputs clauses ...) + ;; Special-case 'modify-inputs' to have one clause per line and custom + ;; indentation. + (let ((head "(modify-inputs ")) + (display head port) + (loop (+ indent 4) + (+ column (string-length head)) + #t + inputs) + (let* ((indent (+ indent 2)) + (column (fold (lambda (clause column) + (newline port) + (display (make-string indent #\space) + port) + (loop indent indent #t clause)) + indent + clauses))) + (display ")" port) + (+ column 1)))) + ((head tail ...) + (unless delimited? (display " " port)) + (display "(" port) + (let* ((new-column (loop indent (+ 1 column) #t head)) + (indent (+ indent (- new-column column))) + (long? (> (length tail) long-list))) + (define column + (fold2 (lambda (item column first?) + (define newline? + ;; Insert a newline if ITEM is itself a list, or if TAIL + ;; is long, but only if ITEM is not the first item. + (and (or (pair? item) long?) + (not first?) (not (comment? item)))) + + (when newline? + (newline port) + (display (make-string indent #\space) port)) + (let ((column (if newline? indent column))) + (values (loop indent + column + (= column indent) + item) + (comment? item)))) + (+ 1 new-column) + #t ;first + tail)) + (display ")" port) + (+ column 1))) + (_ + (let* ((str (object->string obj)) + (len (string-length str))) + (if (> (+ column 1 len) max-width) + (begin + (newline port) + (display (make-string indent #\space) port) + (display str port) + (+ indent len)) + (begin + (unless delimited? (display " " port)) + (display str port) + (+ column (if delimited? 1 2) len)))))))) + +(define (object->string* obj indent) + (call-with-output-string + (lambda (port) + (pretty-print-with-comments port obj + #:indent indent)))) + + +;;; +;;; Simplifying input expressions. +;;; + +(define (simplify-inputs location package str inputs) + "Simplify the inputs field of PACKAGE (a string) at LOCATION; its current +value is INPUTS the corresponding source code is STR. Return a string to +replace STR." + (define (label-matches? label name) + ;; Return true if LABEL matches NAME, a package name. + (or (string=? label name) + (and (string-prefix? "python-" label) + (string-prefix? "python2-" name) + (string=? (string-drop label (string-length "python-")) + (string-drop name (string-length "python2-")))))) + + (define (simplify-input-expression return) + (match-lambda + ((label ('unquote symbol)) symbol) + ((label ('unquote symbol) output) + (list 'quasiquote + (list (list 'unquote symbol) output))) + (_ + ;; Expression doesn't look like a simple input. + (warning location (G_ "~a: complex expression, \ +bailing out~%") + package) + (return str)))) + + (define (simplify-input exp input return) + (define package* package) + + (match input + ((or ((? string? label) (? package? package)) + ((? string? label) (? package? package) + (? string?))) + ;; If LABEL doesn't match PACKAGE's name, then simplifying would incur + ;; a rebuild, and perhaps it would break build-side code relying on + ;; this specific label. + (if (label-matches? label (package-name package)) + ((simplify-input-expression return) exp) + (begin + (warning location (G_ "~a: input label \ +'~a' does not match package name, bailing out~%") + package* label) + (return str)))) + (_ + (warning location (G_ "~a: non-trivial input, \ +bailing out~%") + package*) + (return str)))) + + (define (simplify-expressions exp inputs return) + ;; Simplify the expressions in EXP, which correspond to INPUTS, and return + ;; a list of expressions. Call RETURN with a string when bailing out. + (let loop ((result '()) + (exp exp) + (inputs inputs)) + (match exp + (((? comment? head) . rest) + (loop (cons head result) rest inputs)) + ((head . rest) + (match inputs + ((input . inputs) + ;; HEAD (an sexp) and INPUT (an input tuple) are correlated. + (loop (cons (simplify-input head input return) result) + rest inputs)) + (() + ;; If EXP and INPUTS have a different length, that + ;; means EXP is a non-trivial input list, for example + ;; with input-splicing, conditionals, etc. + (warning location (G_ "~a: input expression is too short~%") + package) + (return str)))) + (() + ;; It's possible for EXP to contain fewer elements than INPUTS, for + ;; example in the case of input splicing. No bailout here. (XXX) + (reverse result))))) + + (define inputs-exp + (call-with-input-string str read-with-comments)) + + (match inputs-exp + (('list _ ...) ;already done + str) + (('modify-inputs _ ...) ;already done + str) + (('quasiquote ;prepending inputs + (exp ... + ('unquote-splicing + ((and symbol (or 'package-inputs 'package-native-inputs + 'package-propagated-inputs)) + arg)))) + (let/ec return + (object->string* + (let ((things (simplify-expressions exp inputs return))) + `(modify-inputs (,symbol ,arg) + (prepend ,@things))) + (location-column location)))) + (('quasiquote ;replacing an input + ((and exp ((? string? to-delete) ('unquote replacement))) + ('unquote-splicing + ('alist-delete (? string? to-delete) + ((and symbol + (or 'package-inputs 'package-native-inputs + 'package-propagated-inputs)) + arg))))) + (let/ec return + (object->string* + (let ((things (simplify-expressions (list exp) + (list (car inputs)) + return))) + `(modify-inputs (,symbol ,arg) + (replace ,to-delete ,replacement))) + (location-column location)))) + + (('quasiquote ;removing an input + (exp ... + ('unquote-splicing + ('alist-delete (? string? to-delete) + ((and symbol + (or 'package-inputs 'package-native-inputs + 'package-propagated-inputs)) + arg))))) + (let/ec return + (object->string* + (let ((things (simplify-expressions exp inputs return))) + `(modify-inputs (,symbol ,arg) + (delete ,to-delete) + (prepend ,@things))) + (location-column location)))) + (('fold 'alist-delete ;removing several inputs + ((and symbol + (or 'package-inputs 'package-native-inputs + 'package-propagated-inputs)) + arg) + ('quote ((? string? to-delete) ...))) + (object->string* + `(modify-inputs (,symbol ,arg) + (delete ,@to-delete)) + (location-column location))) + (('quasiquote ;removing several inputs and adding others + (exp ... + ('unquote-splicing + ('fold 'alist-delete + ((and symbol + (or 'package-inputs 'package-native-inputs + 'package-propagated-inputs)) + arg) + ('quote ((? string? to-delete) ...)))))) + (let/ec return + (object->string* + (let ((things (simplify-expressions exp inputs return))) + `(modify-inputs (,symbol ,arg) + (delete ,@to-delete) + (prepend ,@things))) + (location-column location)))) + (('quasiquote (exp ...)) + (let/ec return + (object->string* + `(list ,@(simplify-expressions exp inputs return)) + (location-column location)))) + (_ + (warning location (G_ "~a: unsupported input style, \ +bailing out~%") + package) + str))) + +(define (simplify-package-inputs package) + "Edit the source code of PACKAGE to simplify its inputs field if needed." + (for-each (lambda (field-name field) + (match (field package) + (() + #f) + (inputs + (match (package-field-location package field-name) + (#f + ;; (unless (null? (field package)) + ;; (warning (package-location package) + ;; (G_ "source location not found for '~a' of '~a'~%") + ;; field-name (package-name package))) + #f) + (location + (edit-expression (location->source-properties location) + (lambda (str) + (simplify-inputs location + (package-name package) + str inputs)))))))) + '(inputs native-inputs propagated-inputs) + (list package-inputs package-native-inputs + package-propagated-inputs))) + + +(define (package-location records is not invalidated as + ;; we modify files. + (sort (if (null? specs) + (fold-packages cons '() #:select? (const #t)) + (map specification->package specs)) + (negate package-location +;;; +;;; 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 (tests-style) + #:use-module (guix packages) + #:use-module (guix scripts style) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module ((guix build utils) #:select (substitute*)) + #:use-module (guix diagnostics) + #:use-module (gnu packages acl) + #:use-module (gnu packages multiprecision) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 pretty-print)) + +(define (call-with-test-package inputs proc) + (call-with-temporary-directory + (lambda (directory) + (call-with-output-file (string-append directory "/my-packages.scm") + (lambda (port) + (pretty-print + `(begin + (define-module (my-packages) + #:use-module (guix) + #:use-module (guix licenses) + #:use-module (gnu packages acl) + #:use-module (gnu packages base) + #:use-module (gnu packages multiprecision) + #:use-module (srfi srfi-1)) + + (define base + (package + (inherit coreutils) + (inputs '()) + (native-inputs '()) + (propagated-inputs '()))) + + (define (sdl-union . lst) + (package + (inherit base) + (name "sdl-union"))) + + (define-public my-coreutils + (package + (inherit base) + ,@inputs + (name "my-coreutils")))) + port))) + + (proc directory)))) + +(define test-directory + ;; Directory where the package definition lives. + (make-parameter #f)) + +(define-syntax-rule (with-test-package fields exp ...) + (call-with-test-package fields + (lambda (directory) + (define file + (string-append directory "/my-packages.scm")) + + ;; Run as a separate process to make sure FILE is reloaded. + (system* "guix" "style" "-L" directory "my-coreutils") + (system* "cat" file) + + (load file) + (parameterize ((test-directory directory)) + exp ...)))) + +(define* (read-lines port line #:optional (count 1)) + "Read COUNT lines from PORT, starting from LINE." + (let loop ((lines '()) + (count count)) + (cond ((< (port-line port) (- line 1)) + (read-char port) + (loop lines count)) + ((zero? count) + (string-concatenate-reverse lines)) + (else + (match (read-line port 'concat) + ((? eof-object?) + (loop lines 0)) + (line + (loop (cons line lines) (- count 1)))))))) + +(define* (read-package-field package field #:optional (count 1)) + (let* ((location (package-field-location package field)) + (file (location-file location)) + (line (location-line location))) + (call-with-input-file (if (string-prefix? "/" file) + file + (string-append (test-directory) "/" + file)) + (lambda (port) + (read-lines port line count))))) + + +(test-begin "style") + +(test-equal "nothing to rewrite" + '() + (with-test-package '() + (package-direct-inputs (@ (my-packages) my-coreutils)))) + +(test-equal "input labels, mismatch" + (list `(("foo" ,gmp) ("bar" ,acl)) + " (inputs `((\"foo\" ,gmp) (\"bar\" ,acl)))\n") + (with-test-package '((inputs `(("foo" ,gmp) ("bar" ,acl)))) + (list (package-direct-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs)))) + +(test-equal "input labels, simple" + (list `(("gmp" ,gmp) ("acl" ,acl)) + " (inputs (list gmp acl))\n") + (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)))) + (list (package-direct-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs)))) + +(test-equal "input labels, long list with one item per line" + (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl)))) + "\ + (list gmp + acl + gmp + acl + gmp + acl + gmp + acl))\n") + (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl) + ("gmp" ,gmp) ("acl" ,acl) + ("gmp" ,gmp) ("acl" ,acl) + ("gmp" ,gmp) ("acl" ,acl)))) + (list (package-direct-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 8)))) + +(test-equal "input labels, sdl-union" + "\ + (list gmp acl + (sdl-union 1 2 3 4)))\n" + (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl) + ("sdl-union" ,(sdl-union 1 2 3 4))))) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 2))) + +(test-equal "input labels, output" + (list `(("gmp" ,gmp "debug") ("acl" ,acl)) + " (inputs (list `(,gmp \"debug\") acl))\n") + (with-test-package '((inputs `(("gmp" ,gmp "debug") ("acl" ,acl)))) + (list (package-direct-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs)))) + +(test-equal "input labels, prepend" + (list `(("gmp" ,gmp) ("acl" ,acl)) + "\ + (modify-inputs (package-propagated-inputs coreutils) + (prepend gmp acl)))\n") + (with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl) + ,@(package-propagated-inputs coreutils)))) + (list (package-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 2)))) + +(test-equal "input labels, prepend + delete" + (list `(("gmp" ,gmp) ("acl" ,acl)) + "\ + (modify-inputs (package-propagated-inputs coreutils) + (delete \"gmp\") + (prepend gmp acl)))\n") + (with-test-package '((inputs `(("gmp" ,gmp) + ("acl" ,acl) + ,@(alist-delete "gmp" + (package-propagated-inputs coreutils))))) + (list (package-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 3)))) + +(test-equal "input labels, prepend + delete multiple" + (list `(("gmp" ,gmp) ("acl" ,acl)) + "\ + (modify-inputs (package-propagated-inputs coreutils) + (delete \"foo\" \"bar\" \"baz\") + (prepend gmp acl)))\n") + (with-test-package '((inputs `(("gmp" ,gmp) + ("acl" ,acl) + ,@(fold alist-delete + (package-propagated-inputs coreutils) + '("foo" "bar" "baz"))))) + (list (package-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 3)))) + +(test-equal "input labels, replace" + (list '() ;there's no "gmp" input to replace + "\ + (modify-inputs (package-propagated-inputs coreutils) + (replace \"gmp\" gmp)))\n") + (with-test-package '((inputs `(("gmp" ,gmp) + ,@(alist-delete "gmp" + (package-propagated-inputs coreutils))))) + (list (package-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 2)))) + +(test-equal "input labels, margin comment" + (list `(("gmp" ,gmp)) + `(("acl" ,acl)) + " (inputs (list gmp)) ;margin comment\n" + " (native-inputs (list acl)) ;another one\n") + (call-with-test-package '((inputs `(("gmp" ,gmp))) + (native-inputs `(("acl" ,acl)))) + (lambda (directory) + (define file + (string-append directory "/my-packages.scm")) + + (substitute* file + (("\"gmp\"(.*)$" _ rest) + (string-append "\"gmp\"" (string-trim-right rest) + " ;margin comment\n")) + (("\"acl\"(.*)$" _ rest) + (string-append "\"acl\"" (string-trim-right rest) + " ;another one\n"))) + (system* "cat" file) + + (system* "guix" "style" "-L" directory "my-coreutils") + + (load file) + (list (package-inputs (@ (my-packages) my-coreutils)) + (package-native-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs) + (read-package-field (@ (my-packages) my-coreutils) 'native-inputs))))) + +(test-equal "input labels, margin comment on long list" + (list (concatenate (make-list 4 `(("gmp" ,gmp) ("acl" ,acl)))) + "\ + (list gmp ;margin comment + acl + gmp ;margin comment + acl + gmp ;margin comment + acl + gmp ;margin comment + acl))\n") + (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl) + ("gmp" ,gmp) ("acl" ,acl) + ("gmp" ,gmp) ("acl" ,acl) + ("gmp" ,gmp) ("acl" ,acl)))) + (lambda (directory) + (define file + (string-append directory "/my-packages.scm")) + + (substitute* file + (("\"gmp\"(.*)$" _ rest) + (string-append "\"gmp\"" (string-trim-right rest) + " ;margin comment\n"))) + (system* "cat" file) + + (system* "guix" "style" "-L" directory "my-coreutils") + + (load file) + (list (package-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 8))))) + +(test-equal "input labels, line comment" + (list `(("gmp" ,gmp) ("acl" ,acl)) + "\ + (inputs (list gmp + ;; line comment! + acl))\n") + (call-with-test-package '((inputs `(("gmp" ,gmp) ("acl" ,acl)))) + (lambda (directory) + (define file + (string-append directory "/my-packages.scm")) + + (substitute* file + ((",gmp\\)(.*)$" _ rest) + (string-append ",gmp)\n ;; line comment!\n" rest))) + + (system* "guix" "style" "-L" directory "my-coreutils") + + (load file) + (list (package-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 3))))) + +(test-equal "input labels, modify-inputs and margin comment" + (list `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr)) + "\ + (modify-inputs (package-propagated-inputs coreutils) + (prepend gmp ;margin comment + acl ;another one + mpfr)))\n") + (call-with-test-package '((inputs + `(("gmp" ,gmp) ("acl" ,acl) ("mpfr" ,mpfr) + ,@(package-propagated-inputs coreutils)))) + (lambda (directory) + (define file + (string-append directory "/my-packages.scm")) + + (substitute* file + ((",gmp\\)(.*)$" _ rest) + (string-append ",gmp) ;margin comment\n" rest)) + ((",acl\\)(.*)$" _ rest) + (string-append ",acl) ;another one\n" rest))) + + (system* "guix" "style" "-L" directory "my-coreutils") + + (load file) + (list (package-inputs (@ (my-packages) my-coreutils)) + (read-package-field (@ (my-packages) my-coreutils) 'inputs 4))))) + +(test-end) + +;; Local Variables: +;; eval: (put 'with-test-package 'scheme-indent-function 1) +;; eval: (put 'call-with-test-package 'scheme-indent-function 1) +;; End: