From patchwork Sun Jan 13 15:47:31 2019 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: 737 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 08B9916A42; Sun, 13 Jan 2019 15:48:52 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 8A6EE169F7 for ; Sun, 13 Jan 2019 15:48:51 +0000 (GMT) Received: from localhost ([127.0.0.1]:41784 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gii0J-0005ZJ-6R for patchwork@mira.cbaines.net; Sun, 13 Jan 2019 10:48:51 -0500 Received: from eggs.gnu.org ([209.51.188.92]:55594) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gihza-0004xj-B2 for guix-patches@gnu.org; Sun, 13 Jan 2019 10:48:07 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1gihzZ-0004p0-2W for guix-patches@gnu.org; Sun, 13 Jan 2019 10:48:06 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:58741) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1gihzY-0004ol-Tu for guix-patches@gnu.org; Sun, 13 Jan 2019 10:48:05 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1gihzY-0008OF-R1 for guix-patches@gnu.org; Sun, 13 Jan 2019 10:48:04 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#34060] [PATCH 08/10] edit: Use 'specification->location' to read information from the cache. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sun, 13 Jan 2019 15:48:04 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 34060 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 34060@debbugs.gnu.org Received: via spool by 34060-submit@debbugs.gnu.org id=B34060.154739447232170 (code B ref 34060); Sun, 13 Jan 2019 15:48:04 +0000 Received: (at 34060) by debbugs.gnu.org; 13 Jan 2019 15:47:52 +0000 Received: from localhost ([127.0.0.1]:58010 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gihzL-0008Mi-Dh for submit@debbugs.gnu.org; Sun, 13 Jan 2019 10:47:51 -0500 Received: from hera.aquilenet.fr ([185.233.100.1]:49278) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gihzF-0008LE-Cy for 34060@debbugs.gnu.org; Sun, 13 Jan 2019 10:47:45 -0500 Received: from localhost (localhost [127.0.0.1]) by hera.aquilenet.fr (Postfix) with ESMTP id 1E1BC184B; Sun, 13 Jan 2019 16:47:45 +0100 (CET) X-Virus-Scanned: Debian amavisd-new at aquilenet.fr Received: from hera.aquilenet.fr ([127.0.0.1]) by localhost (hera.aquilenet.fr [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id 3Af6jyLNrkDq; Sun, 13 Jan 2019 16:47:44 +0100 (CET) Received: from gnu.org (unknown [IPv6:2a01:e0a:1d:7270:af76:b9b:ca24:c465]) by hera.aquilenet.fr (Postfix) with ESMTPSA id 1B72B17CF; Sun, 13 Jan 2019 16:47:42 +0100 (CET) From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Sun, 13 Jan 2019 16:47:31 +0100 Message-Id: <20190113154733.29737-8-ludo@gnu.org> X-Mailer: git-send-email 2.20.1 In-Reply-To: <20190113154733.29737-1-ludo@gnu.org> References: <20190113154733.29737-1-ludo@gnu.org> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 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 That way 'guix edit' doesn't need to load any package module. * gnu/packages.scm (find-package-locations, specification->location): New procedures. * guix/scripts/edit.scm (package->location-specification): Rename to... (location->location-specification): ... this. Expect a location object instead of a package. (guix-edit): Use 'specification->location' instead of 'specification->package'. * tests/packages.scm ("find-package-locations") ("find-package-locations with cache") ("specification->location"): New tests. --- gnu/packages.scm | 51 +++++++++++++++++++++++++++++++++++++++++++ guix/scripts/edit.scm | 29 ++++++++++-------------- tests/packages.scm | 23 +++++++++++++++++++ 3 files changed, 85 insertions(+), 18 deletions(-) diff --git a/gnu/packages.scm b/gnu/packages.scm index 6796db80a4..cf655e7448 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -55,10 +55,12 @@ fold-packages find-packages-by-name + find-package-locations find-best-packages-by-name specification->package specification->package+output + specification->location specifications->manifest generate-package-cache)) @@ -274,6 +276,31 @@ decreasing version order." versions modules symbols))) (find-packages-by-name/direct name version))) +(define* (find-package-locations name #:optional version) + "Return a list of version/location pairs corresponding to each package +matching NAME and VERSION." + (define cache + (load-package-cache (current-profile))) + + (if (and cache (cache-is-authoritative?)) + (match (cache-lookup cache name) + (#f '()) + ((#(name versions modules symbols outputs + supported? deprecated? + files lines columns) ...) + (fold (lambda (version* file line column result) + (if (and file + (or (not version) + (version-prefix? version version*))) + (alist-cons version* (location file line column) + result) + result)) + '() + versions files lines columns))) + (map (lambda (package) + (cons (package-version package) (package-location package))) + (find-packages-by-name/direct name version)))) + (define (find-best-packages-by-name name version) "If version is #f, return the list of packages named NAME with the highest version numbers; otherwise, return the list of packages named NAME and at @@ -393,6 +420,30 @@ present, return the preferred newest version." (let-values (((name version) (package-name->name+version spec))) (%find-package spec name version))) +(define (specification->location spec) + "Return the location of the highest-numbered package matching SPEC, a +specification such as \"guile@2\" or \"emacs\"." + (let-values (((name version) (package-name->name+version spec))) + (match (find-package-locations name version) + (() + (if version + (leave (G_ "~A: package not found for version ~a~%") name version) + (leave (G_ "~A: unknown package~%") name))) + (lst + (let* ((highest (match lst (((version . _) _ ...) version))) + (locations (take-while (match-lambda + ((version . location) + (string=? version highest))) + lst))) + (match locations + (((version . location) . rest) + (unless (null? rest) + (warning (G_ "ambiguous package specification `~a'~%") spec) + (warning (G_ "choosing ~a@~a from ~a~%") + name version + (location->string location))) + location))))))) + (define* (specification->package+output spec #:optional (output "out")) "Return the package and output specified by SPEC, or #f and #f; SPEC may optionally contain a version number and an output name, as in these examples: diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 8b2b61d76a..da3d2775e8 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2019 Ludovic Courtès ;;; Copyright © 2015 Mathieu Lirzin ;;; ;;; This file is part of GNU Guix. @@ -21,7 +21,6 @@ #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix utils) - #:use-module (guix packages) #:use-module (gnu packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-37) @@ -63,14 +62,13 @@ Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n")) file path)) absolute-file-name)) -(define (package->location-specification package) - "Return the location specification for PACKAGE for a typical editor command +(define (location->location-specification location) + "Return the location specification for LOCATION for a typical editor command line." - (let ((loc (package-location package))) - (list (string-append "+" - (number->string - (location-line loc))) - (search-path* %load-path (location-file loc))))) + (list (string-append "+" + (number->string + (location-line location))) + (search-path* %load-path (location-file location)))) (define (guix-edit . args) @@ -83,18 +81,13 @@ line." '())) (with-error-handling - (let* ((specs (reverse (parse-arguments))) - (packages (map specification->package specs))) - (for-each (lambda (package) - (unless (package-location package) - (leave (G_ "source location of package '~a' is unknown~%") - (package-full-name package)))) - packages) + (let* ((specs (reverse (parse-arguments))) + (locations (map specification->location specs))) (catch 'system-error (lambda () - (let ((file-names (append-map package->location-specification - packages))) + (let ((file-names (append-map location->location-specification + locations))) ;; Use `system' instead of `exec' in order to sanely handle ;; possible command line arguments in %EDITOR. (exit (system (string-join (cons (%editor) file-names)))))) diff --git a/tests/packages.scm b/tests/packages.scm index 2720ba5a15..8aa117a2e7 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1131,6 +1131,29 @@ (lambda (key . args) key))) +(test-equal "find-package-locations" + (map (lambda (package) + (cons (package-version package) + (package-location package))) + (find-packages-by-name "guile")) + (find-package-locations "guile")) + +(test-equal "find-package-locations with cache" + (map (lambda (package) + (cons (package-version package) + (package-location package))) + (find-packages-by-name "guile")) + (call-with-temporary-directory + (lambda (cache) + (generate-package-cache cache) + (mock ((guix describe) current-profile (const cache)) + (mock ((gnu packages) cache-is-authoritative? (const #t)) + (find-package-locations "guile")))))) + +(test-equal "specification->location" + (package-location (specification->package "guile@2")) + (specification->location "guile@2")) + (test-end "packages") ;;; Local Variables: