From debbugs-submit-bounces@debbugs.gnu.org Sun May 03 11:02:28 2020 Received: (at 39258) by debbugs.gnu.org; 3 May 2020 15:02:28 +0000 Received: from localhost ([127.0.0.1]:57640 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jVG8R-0005An-8T for submit@debbugs.gnu.org; Sun, 03 May 2020 11:02:27 -0400 Received: from mail-wr1-f67.google.com ([209.85.221.67]:34924) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jVG8P-0005AN-DX for 39258@debbugs.gnu.org; Sun, 03 May 2020 11:02:25 -0400 Received: by mail-wr1-f67.google.com with SMTP id x18so17833251wrq.2 for <39258@debbugs.gnu.org>; Sun, 03 May 2020 08:02:25 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=from:to:cc:subject:date:message-id:in-reply-to:references :mime-version:content-transfer-encoding; bh=g/Ap+DsFXX88hbi+Yvm1efNAcOgiB+00QdKk0X55xTc=; b=h8CE3txtoW2DMHQVxDWhhGVIKkbsKKPieGNdtY4LGffYuTGeRMJZ8nQqIO5QAc8WX9 eNHfn0F+VY3qD6BDUM1nYno5isLWW7nnk1NqzL5edC2yDspUR5PcW7xADD3w301CHS+3 EeuuoLEwWa7scP/1Eb1mVS3o2bPzCPwuvjS2CniWBBsEzx9cikBdb4n5/t1DhWYsovfT 5TVLROpFiVQK3MS3AJqCeJT1b9CPdPkBCatjAsNCOe6HgGihtJ5ExuXHZ0BQNEJJ7nMo xKUe30c0hH6hlR9Vd4wRVGA9qE0eSB1nP7xvDXd9bG36OR3kHPxduJzbY48iiUiKkiz2 9ShQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:from:to:cc:subject:date:message-id:in-reply-to :references:mime-version:content-transfer-encoding; bh=g/Ap+DsFXX88hbi+Yvm1efNAcOgiB+00QdKk0X55xTc=; b=Q/fbeGgqtvtX6oqH67Fc5tj/eR6e7xrzcZKTHHRa8HaKTUhj00cueX4LlIAvXKt3iX iBa1AmG5x9B6h6anU1OTU5pQqMw17BgkQxMX0wbl5tHkPFDcS3T2w99n1DiflTSpzHhW 2MNr2PDx4gBEDDqaulfgcS63uGRPa4qE0JhHnMwdZnnC1q7yzwWxYloZPZ+VaxmeV+kQ uPs5JYbn/6s6p0Xak+eArtFIhSUyaRZpIBBrTg+k6Nc7Xaz6vNMEY1/CyZ5U76Mtny5q 5tH3nwPJnnS7o7HsXPmSpT6TzKwBA0WjxEBJQPAPa9npvjrfiZZ4EWrtVVXRBZTM81DW 6w+w== X-Gm-Message-State: AGi0PuZNvOzZbOh4xz1DSZIh920u3OE6hM2nIFEXegCa9mHdtUDAN+eG DZ9/L2k2wQu4C2vzq6XwSA+1AAqq X-Google-Smtp-Source: APiQypI+C5VHCpwASn0z9sOBkb905oUanZs6V+nM8elFaB1cKtUSw6gI/znRc2Ce3she9ZtYcZCcbA== X-Received: by 2002:adf:fcc8:: with SMTP id f8mr14213653wrs.230.1588518139268; Sun, 03 May 2020 08:02:19 -0700 (PDT) Received: from localhost.localdomain (57.246.195.77.rev.sfr.net. [77.195.246.57]) by smtp.gmail.com with ESMTPSA id x13sm9787829wmc.5.2020.05.03.08.02.18 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sun, 03 May 2020 08:02:18 -0700 (PDT) From: zimoun To: 39258@debbugs.gnu.org Subject: [PATCH v4 2/3] DRAFT packages: Add new procedure 'fold-packages*'. Date: Sun, 3 May 2020 17:01:53 +0200 Message-Id: <20200503150154.26532-3-zimon.toutoune@gmail.com> X-Mailer: git-send-email 2.26.1 In-Reply-To: <20200503150154.26532-1-zimon.toutoune@gmail.com> References: <20200503150154.26532-1-zimon.toutoune@gmail.com> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Score: 0.0 (/) X-Debbugs-Envelope-To: 39258 Cc: arunisaac@systemreboot.net, mail@ambrevar.xyz, ludo@gnu.org, zimoun X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --- gnu/packages.scm | 47 ++++++++++++++++++++++++++++++++++++++++++++++ guix/ui.scm | 29 +++++++++++++++++----------- tests/packages.scm | 31 ++++++++++++++++++++++++++++++ 3 files changed, 96 insertions(+), 11 deletions(-) diff --git a/gnu/packages.scm b/gnu/packages.scm index fa18f81487..a0c5835b8b 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -55,6 +55,7 @@ fold-packages fold-available-packages + fold-packages* find-newest-available-packages find-packages-by-name @@ -253,6 +254,52 @@ is guaranteed to never traverse the same package twice." init modules)) +(define (fold-packages* proc init) + "Fold (PROC PACKAGE RESULT) over the list of available packages. When a +package cache is available, this procedure does not actually load any package +module. Moreover when package cache is available, this procedure +re-constructs a new package skipping some package record field. The usage of +this procedure is User Interface (ui) only." + (define cache + (load-package-cache (current-profile))) + + (define license (@@ (guix licenses) license)) + + (if (and cache (cache-is-authoritative?)) + (vhash-fold (lambda (name vector result) + (match vector + (#(name version module symbol outputs + supported? deprecated? + file line column + synopsis description home-page + build-system-name build-system-description + supported-systems direct-inputs + license-name license-uri license-comment) + (proc (package + (name name) + (version version) + (source #f) ;TODO: ? + (build-system + (build-system + (name (string->symbol build-system-name)) + (description build-system-description) + (lower #f))) ; never used by ui + (inputs ; list of "full-name@version" + (list 'cache direct-inputs)) + (outputs outputs) + (synopsis synopsis) + (description description) + (license (license + license-name license-uri license-comment)) + (home-page home-page) + (supported-systems (list 'cache supported-systems)) + (location (location + file line column))) + result)))) + init + cache) + (fold-packages proc init))) + (define %package-cache-file ;; Location of the package cache. "/lib/guix/package.cache") diff --git a/guix/ui.scm b/guix/ui.scm index 1e24fe5dca..257d119798 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1416,13 +1416,10 @@ HYPERLINKS? is true, emit hyperlink escape sequences when appropriate." ;; the initial "+ " prefix. (if (> width 2) (- width 2) width)) - (define (dependencies->recutils packages) - (let ((list (string-join (delete-duplicates - (map package-full-name - (sort packages packagerecutils - (fill-paragraph list width* - (string-length "dependencies: "))))) + (define (dependencies->string packages) + (string-join (delete-duplicates + (map package-full-name + (sort packages packagerecutils (filter package? inputs))))) + (let ((dependencies + (match (package-direct-inputs p) + (('cache inputs) + (string-join inputs)) + (((labels inputs . _) ...) + (dependencies->string (filter package? inputs)))))) + (string->recutils + (fill-paragraph dependencies width* + (string-length "dependencies: "))))) (format port "location: ~a~%" (or (and=> (package-location p) (if hyperlinks? location->hyperlink location->string)) diff --git a/tests/packages.scm b/tests/packages.scm index 7a8b5e4a2d..4504f6cf33 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1169,6 +1169,37 @@ ((one) (eq? one guile-2.0)))) +(test-assert "fold-packages* hello with/without cache" + (let () + (define (equal-package? p1 p2) + ;; fold-package* re-constructs a new package skipping 'source' and 'lower' + ;; so equal? does not apply + (and (equal? (package-full-name p1) (package-full-name p2)) + (equal? (package-description p1) (package-description p2)))) + + (define no-cache + (fold-packages* (lambda (p r) + (if (string=? (package-name p) "hello") + p + r)) + #f)) + + (define from-cache + (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)) + (fold-packages* (lambda (p r) + (if (string=? (package-name p) "hello") + p + r)) + #f)))))) + + (and (equal? no-cache hello) + (equal-package? from-cache hello) + (equal-package? no-cache from-cache)))) + (test-assert "fold-available-packages with/without cache" (let () (define no-cache -- 2.26.1