From mboxrd@z Thu Jan 1 00:00:00 1970 From: Eric Bavier Subject: [PATCH 1/2] guix: packages: Add package-direct-sources and package-transitive-sources. Date: Fri, 24 Apr 2015 08:19:21 -0500 Message-ID: <1429881562-19456-2-git-send-email-bavier@member.fsf.org> References: <1429881562-19456-1-git-send-email-bavier@member.fsf.org> Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:35826) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1YldUu-0003N6-HA for guix-devel@gnu.org; Fri, 24 Apr 2015 09:18:26 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1YldUq-0000Xy-T3 for guix-devel@gnu.org; Fri, 24 Apr 2015 09:18:24 -0400 Received: from mail2.openmailbox.org ([62.4.1.33]:58081) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1YldUq-0000XD-NN for guix-devel@gnu.org; Fri, 24 Apr 2015 09:18:20 -0400 In-Reply-To: <1429881562-19456-1-git-send-email-bavier@member.fsf.org> List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org To: guix-devel@gnu.org * guix/tests.scm (dummy-origin): New syntax. * guix/packages.scm (package-direct-sources) (package-transitive-sources): New procedures. * tests/packages.scm: Test them. --- guix/packages.scm | 24 ++++++++++++++++++++++++ guix/tests.scm | 10 +++++++++- tests/packages.scm | 30 ++++++++++++++++++++++++++++++ 3 files changed, 63 insertions(+), 1 deletion(-) diff --git a/guix/packages.scm b/guix/packages.scm index fde46d5..ff0a466 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -82,6 +82,8 @@ package-location package-field-location + package-direct-sources + package-transitive-sources package-direct-inputs package-transitive-inputs package-transitive-target-inputs @@ -519,6 +521,28 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET." ((input rest ...) (loop rest (cons input result)))))) +(define (package-direct-sources package) + "Return all source origins associated with PACKAGE; including origins in +PACKAGE's inputs." + `(,@(or (and=> (package-source package) list) '()) + ,@(filter-map (match-lambda + ((_ (? origin? orig) _ ...) + orig) + (_ #f)) + (package-direct-inputs package)))) + +(define (package-transitive-sources package) + "Return PACKAGE's direct sources, and their direct sources, recursively." + (delete-duplicates + (concatenate (filter-map (match-lambda + ((_ (? origin? orig) _ ...) + (list orig)) + ((_ (? package? p) _ ...) + (package-direct-sources p)) + (_ #f)) + (bag-transitive-inputs + (package->bag package)))))) + (define (package-direct-inputs package) "Return all the direct inputs of PACKAGE---i.e, its direct inputs along with their propagated inputs." diff --git a/guix/tests.scm b/guix/tests.scm index 080ee9c..87e6cc2 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -37,7 +37,8 @@ %substitute-directory with-derivation-narinfo with-derivation-substitute - dummy-package)) + dummy-package + dummy-origin)) ;;; Commentary: ;;; @@ -219,6 +220,13 @@ initialized with default values, and with EXTRA-FIELDS set as specified." (synopsis #f) (description #f) (home-page #f) (license #f))) +(define-syntax-rule (dummy-origin extra-fields ...) + "Return a \"dummy\" origin, with all its compulsory fields initialized with +default values, and with EXTRA-FIELDS set as specified." + (origin extra-fields ... + (method #f) (uri "http://www.example.com") + (sha256 (base32 (make-string 52 #\x))))) + ;; Local Variables: ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1) ;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2) diff --git a/tests/packages.scm b/tests/packages.scm index 9191032..c1bd697 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -155,6 +155,36 @@ (package-transitive-supported-systems d) (package-transitive-supported-systems e)))) +(let* ((o (dummy-origin)) + (u (dummy-origin)) + (i (dummy-origin)) + (a (dummy-package "a")) + (b (dummy-package "b" + (inputs `(("a" ,a) ("i" ,i))))) + (c (package (inherit b) (source o))) + (d (dummy-package "d" + (build-system trivial-build-system) + (source u) (inputs `(("c" ,c)))))) + (test-assert "package-direct-sources, no source" + (null? (package-direct-sources a))) + (test-equal "package-direct-sources, #f source" + (list i) + (package-direct-sources b)) + (test-equal "package-direct-sources, not input source" + (list u) + (package-direct-sources d)) + (test-assert "package-direct-sources" + (let ((s (package-direct-sources c))) + (and (= (length (pk 's-sources s)) 2) + (member o s) + (member i s)))) + (test-assert "package-transitive-sources" + (let ((s (package-transitive-sources d))) + (and (= (length (pk 'd-sources s)) 3) + (member o s) + (member i s) + (member u s))))) + (test-equal "package-transitive-supported-systems, implicit inputs" %supported-systems -- 1.7.9.5