From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:470:142:3::10]:43063) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1ia7VU-0007gQ-Ch for guix-patches@gnu.org; Wed, 27 Nov 2019 19:18:05 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ia7VS-0003xt-TQ for guix-patches@gnu.org; Wed, 27 Nov 2019 19:18:04 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:50450) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1ia7VS-0003x0-KZ for guix-patches@gnu.org; Wed, 27 Nov 2019 19:18:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ia7VS-0005LI-EX for guix-patches@gnu.org; Wed, 27 Nov 2019 19:18:02 -0500 Subject: [bug#38408] [PATCH 1/3] gnu: added new function, find-packages-by-name*/direct Resent-Message-ID: From: Martin Becze Date: Wed, 27 Nov 2019 19:16:50 -0500 Message-Id: In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 38408@debbugs.gnu.org Cc: efraim@flashner.co.il, Martin Becze * gnu/packages.scm (find-packages-by-naem*/direct) --- gnu/packages.scm | 41 +++++++++++++++++++++++++++++++++++++++++ tests/packages.scm | 13 +++++++++++++ 2 files changed, 54 insertions(+) diff --git a/gnu/packages.scm b/gnu/packages.scm index 959777ff8f..cca2a393e5 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2014 Eric Bavier ;;; Copyright © 2016, 2017 Alex Kost ;;; Copyright © 2016 Mathieu Lirzin +;;; Copyright © 2019 Martin Becze ;;; ;;; This file is part of GNU Guix. ;;; @@ -52,7 +53,9 @@ %default-package-module-path fold-packages + fold-packages* fold-available-packages + find-packages-by-name*/direct find-newest-available-packages find-packages-by-name @@ -250,6 +253,23 @@ is guaranteed to never traverse the same package twice." init modules)) +(define* (fold-packages* proc init + #:optional + (modules (all-modules (%package-module-path) + #:warn + warn-about-load-error)) + #:key (select? (negate hidden-package?))) + "Call (PROC PACKAGE RESULT) for each available package defined in one of +MODULES that matches SELECT?, using INIT as the initial value of RESULT. It +is guaranteed to never traverse the same package twice." + (fold-module-public-variables* (lambda (module symbol var result) + (let ((object (variable-ref var))) + (if (and (package? object) (select? object)) + (proc module symbol object result) + result))) + init + modules)) + (define %package-cache-file ;; Location of the package cache. "/lib/guix/package.cache") @@ -297,6 +317,27 @@ decreasing version order." matching) matching))))) +(define find-packages-by-name*/direct ;bypass the cache + (let ((packages (delay + (fold-packages* (lambda (mod sym p r) + (vhash-cons (package-name p) (list mod sym p) r)) + vlist-null))) + (version>? (match-lambda* + (((_ _ versions) ..1) + (apply version>? (map package-version versions)))))) + (lambda* (name #:optional version) + "Return the list of ( ) with the given NAME. If + VERSION is not #f, then only return packages whose version is prefixed by + VERSION, sorted in decreasing version order." + (let ((matching (sort (vhash-fold* cons '() name (force packages)) + version>?))) + (if version + (filter (match-lambda + ((_ _ package) + (version-prefix? version (package-version package)))) + matching) + matching))))) + (define (cache-lookup cache name) "Lookup package NAME in CACHE. Return a list sorted in increasing version order." diff --git a/tests/packages.scm b/tests/packages.scm index 423c5061aa..9f02b0d5d2 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © Jan (janneke) Nieuwenhuizen +;;; Copyright © 2019 Martin Becze ;;; ;;; This file is part of GNU Guix. ;;; @@ -1135,11 +1136,23 @@ (((? (cut eq? hello <>))) #t) (wrong (pk 'find-packages-by-name wrong #f)))) +(test-assert "find-packages-by-name*/direct" + (match (find-packages-by-name*/direct "hello") + ((((? (cut eq? (resolve-interface '(gnu packages base)) <>)) + (? (cut eq? 'hello <>)) + (? (cut eq? hello <>)))) #t))) + (test-assert "find-packages-by-name with version" (match (find-packages-by-name "hello" (package-version hello)) (((? (cut eq? hello <>))) #t) (wrong (pk 'find-packages-by-name wrong #f)))) +(test-assert "find-packages-by-name*/direct with version" + (match (find-packages-by-name*/direct "hello" (package-version hello)) + ((((? (cut eq? (resolve-interface '(gnu packages base)) <>)) + (? (cut eq? 'hello <>)) + (? (cut eq? hello <>)))) #t))) + (test-equal "find-packages-by-name with cache" (find-packages-by-name "guile") (call-with-temporary-directory -- 2.24.0