From 25af35fa32bf6c991510406a330d4a42bd5beba8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Mar 2020 12:45:12 +0100 Subject: profiles: Use 'mapm/accumulate-builds'. * guix/profiles.scm (check-for-collisions): Use 'mapm/accumulate-builds' to lower manifest entries. Call 'foldm' over the already-lowered entries. (profile-derivation): Use 'mapm/accumulate-builds' instead of 'mapm' when calling HOOKS. --- guix/profiles.scm | 59 +++++++++++++++++++++++++++++++------------------------ 1 file changed, 33 insertions(+), 26 deletions(-) diff --git a/guix/profiles.scm b/guix/profiles.scm index 3a6498993c..ad9878f370 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014, 2016 Alex Kost ;;; Copyright © 2015 Mark H Weaver @@ -280,29 +280,37 @@ file name." (define lookup (manifest-entry-lookup manifest)) - (with-monad %store-monad + (define candidates + (filter-map (lambda (entry) + (let ((other (lookup (manifest-entry-name entry) + (manifest-entry-output entry)))) + (and other (list entry other)))) + (manifest-transitive-entries manifest))) + + (define lower-pair + (match-lambda + ((first second) + (mlet %store-monad ((first (lower-manifest-entry first system + #:target target)) + (second (lower-manifest-entry second system + #:target target))) + (return (list first second)))))) + + ;; Start by lowering CANDIDATES "in parallel". + (mlet %store-monad ((lst (mapm/accumulate-builds lower-pair candidates))) (foldm %store-monad - (lambda (entry result) - (match (lookup (manifest-entry-name entry) - (manifest-entry-output entry)) - ((? manifest-entry? second) ;potential conflict - (mlet %store-monad ((first (lower-manifest-entry entry system - #:target - target)) - (second (lower-manifest-entry second system - #:target - target))) - (if (string=? (manifest-entry-item first) - (manifest-entry-item second)) - (return result) - (raise (condition - (&profile-collision-error - (entry first) - (conflict second))))))) - (#f ;no conflict - (return result)))) + (lambda (entries result) + (match entries + ((first second) + (if (string=? (manifest-entry-item first) + (manifest-entry-item second)) + (return result) + (raise (condition + (&profile-collision-error + (entry first) + (conflict second)))))))) #t - (manifest-transitive-entries manifest)))) + lst))) (define* (package->manifest-entry package #:optional (output "out") #:key (parent (delay #f)) @@ -1521,10 +1529,9 @@ are cross-built for TARGET." #:target target))) (extras (if (null? (manifest-entries manifest)) (return '()) - (mapm %store-monad - (lambda (hook) - (hook manifest)) - hooks)))) + (mapm/accumulate-builds (lambda (hook) + (hook manifest)) + hooks)))) (define inputs (append (filter-map (lambda (drv) (and (derivation? drv) -- cgit v1.2.3