22 files changed, 231 insertions(+), 156 deletions(-)

M Makefile.am
M gnu/packages.scm
M gnu/packages/bootstrap.scm
M gnu/services/herd.scm
M guix/build-system/gnu.scm
M guix/build-system/python.scm
A guix/combinators.scm
M guix/derivations.scm
M guix/gnu-maintenance.scm
M guix/import/elpa.scm
M guix/scripts/archive.scm
M guix/scripts/build.scm
M guix/scripts/graph.scm
M guix/scripts/lint.scm
M guix/scripts/size.scm
M guix/scripts/substitute.scm
M guix/serialization.scm
M guix/store.scm
M guix/ui.scm
M guix/utils.scm
A tests/combinators.scm
M tests/utils.scm

@@ 38,6 38,7 @@ MODULES =					\
   guix/hash.scm					\
   guix/pk-crypto.scm				\
   guix/pki.scm					\
+  guix/combinators.scm				\
   guix/utils.scm				\
   guix/sets.scm					\
   guix/download.scm				\


@@ 231,6 232,7 @@ SCM_TESTS =					\
   tests/ui.scm					\
   tests/records.scm				\
   tests/upstream.scm				\
+  tests/combinators.scm				\
   tests/utils.scm				\
   tests/build-utils.scm				\
   tests/packages.scm				\

@@ 24,6 24,7 @@
   #:use-module (guix packages)
   #:use-module (guix ui)
   #:use-module (guix utils)
+  #:use-module (guix combinators)
   #:use-module ((guix build utils)
                 #:select ((package-name->name+version
                            . hyphen-separated-name->name+version)))

@@ 27,7 27,8 @@
   #:use-module (guix build-system trivial)
   #:use-module ((guix store) #:select (add-to-store add-text-to-store))
   #:use-module ((guix derivations) #:select (derivation))
-  #:use-module (guix utils)
+  #:use-module ((guix utils) #:select (gnu-triplet->nix-system))
+  #:use-module (guix combinators)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)

@@ 17,7 17,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu services herd)
-  #:use-module (guix utils)
+  #:use-module (guix combinators)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-34)

@@ 19,6 19,7 @@
 (define-module (guix build-system gnu)
   #:use-module (guix store)
   #:use-module (guix utils)
+  #:use-module (guix combinators)
   #:use-module (guix derivations)
   #:use-module (guix search-paths)
   #:use-module (guix build-system)

@@ 21,6 21,7 @@
 (define-module (guix build-system python)
   #:use-module (guix store)
   #:use-module (guix utils)
+  #:use-module (guix combinators)
   #:use-module (guix packages)
   #:use-module (guix derivations)
   #:use-module (guix search-paths)

@@ 0,0 1,116 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix combinators)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist)
+  #:export (memoize
+            fold2
+            fold-tree
+            fold-tree-leaves
+            compile-time-value))
+
+;;; Commentary:
+;;;
+;;; This module provides useful combinators that complement SRFI-1 and
+;;; friends.
+;;;
+;;; Code:
+
+(define (memoize proc)
+  "Return a memoizing version of PROC."
+  (let ((cache (make-hash-table)))
+    (lambda args
+      (let ((results (hash-ref cache args)))
+        (if results
+            (apply values results)
+            (let ((results (call-with-values (lambda ()
+                                               (apply proc args))
+                             list)))
+              (hash-set! cache args results)
+              (apply values results)))))))
+
+(define fold2
+  (case-lambda
+    ((proc seed1 seed2 lst)
+     "Like `fold', but with a single list and two seeds."
+     (let loop ((result1 seed1)
+                (result2 seed2)
+                (lst     lst))
+       (if (null? lst)
+           (values result1 result2)
+           (call-with-values
+               (lambda () (proc (car lst) result1 result2))
+             (lambda (result1 result2)
+               (loop result1 result2 (cdr lst)))))))
+    ((proc seed1 seed2 lst1 lst2)
+     "Like `fold', but with a two lists and two seeds."
+     (let loop ((result1 seed1)
+                (result2 seed2)
+                (lst1    lst1)
+                (lst2    lst2))
+       (if (or (null? lst1) (null? lst2))
+           (values result1 result2)
+           (call-with-values
+               (lambda () (proc (car lst1) (car lst2) result1 result2))
+             (lambda (result1 result2)
+               (fold2 proc result1 result2 (cdr lst1) (cdr lst2)))))))))
+
+(define (fold-tree proc init children roots)
+  "Call (PROC NODE RESULT) for each node in the tree that is reachable from
+ROOTS, using INIT as the initial value of RESULT.  The order in which nodes
+are traversed is not specified, however, each node is visited only once, based
+on an eq? check.  Children of a node to be visited are generated by
+calling (CHILDREN NODE), the result of which should be a list of nodes that
+are connected to NODE in the tree, or '() or #f if NODE is a leaf node."
+  (let loop ((result init)
+             (seen vlist-null)
+             (lst roots))
+    (match lst
+      (() result)
+      ((head . tail)
+       (if (not (vhash-assq head seen))
+           (loop (proc head result)
+                 (vhash-consq head #t seen)
+                 (match (children head)
+                   ((or () #f) tail)
+                   (children (append tail children))))
+           (loop result seen tail))))))
+
+(define (fold-tree-leaves proc init children roots)
+  "Like fold-tree, but call (PROC NODE RESULT) only for leaf nodes."
+  (fold-tree
+   (lambda (node result)
+     (match (children node)
+       ((or () #f) (proc node result))
+       (else result)))
+   init children roots))
+
+(define-syntax compile-time-value                 ;not quite at home
+  (syntax-rules ()
+    "Evaluate the given expression at compile time.  The expression must
+evaluate to a simple datum."
+    ((_ exp)
+     (let-syntax ((v (lambda (s)
+                       (let ((val exp))
+                         (syntax-case s ()
+                           (_ #`'#,(datum->syntax s val)))))))
+       v))))
+
+;;; combinators.scm ends here

@@ 30,6 30,7 @@
   #:use-module (ice-9 vlist)
   #:use-module (guix store)
   #:use-module (guix utils)
+  #:use-module (guix combinators)
   #:use-module (guix monads)
   #:use-module (guix hash)
   #:use-module (guix base32)

@@ 1,5 1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;;
 ;;; This file is part of GNU Guix.


@@ 30,6 30,7 @@
   #:use-module (guix http-client)
   #:use-module (guix ftp-client)
   #:use-module (guix utils)
+  #:use-module (guix combinators)
   #:use-module (guix records)
   #:use-module (guix upstream)
   #:use-module (guix packages)

@@ 35,8 35,8 @@
   #:use-module (guix base32)
   #:use-module (guix upstream)
   #:use-module (guix packages)
-  #:use-module ((guix utils) #:select (call-with-temporary-output-file
-                                       memoize))
+  #:use-module ((guix combinators) #:select (memoize))
+  #:use-module ((guix utils) #:select (call-with-temporary-output-file))
   #:export (elpa->guix-package
             %elpa-updater))
 

@@ 19,6 19,7 @@
 (define-module (guix scripts archive)
   #:use-module (guix config)
   #:use-module (guix utils)
+  #:use-module (guix combinators)
   #:use-module ((guix build utils) #:select (mkdir-p))
   #:use-module ((guix serialization) #:select (restore-file))
   #:use-module (guix store)

@@ 24,6 24,7 @@
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix grafts)
+  #:use-module (guix combinators)
 
   ;; Use the procedure that destructures "NAME-VERSION" forms.
   #:use-module ((guix utils) #:hide (package-name->name+version))

@@ 21,7 21,7 @@
   #:use-module (guix graph)
   #:use-module (guix grafts)
   #:use-module (guix scripts)
-  #:use-module (guix utils)
+  #:use-module (guix combinators)
   #:use-module (guix packages)
   #:use-module (guix monads)
   #:use-module (guix store)

@@ 31,6 31,7 @@
   #:use-module (guix records)
   #:use-module (guix ui)
   #:use-module (guix utils)
+  #:use-module (guix combinators)
   #:use-module (guix scripts)
   #:use-module (guix gnu-maintenance)
   #:use-module (guix monads)

@@ 21,7 21,7 @@
   #:use-module (guix scripts)
   #:use-module (guix store)
   #:use-module (guix monads)
-  #:use-module (guix utils)
+  #:use-module (guix combinators)
   #:use-module (guix grafts)
   #:use-module (guix packages)
   #:use-module (guix derivations)

@@ 21,6 21,7 @@
   #:use-module (guix ui)
   #:use-module ((guix store) #:hide (close-connection))
   #:use-module (guix utils)
+  #:use-module (guix combinators)
   #:use-module (guix config)
   #:use-module (guix records)
   #:use-module (guix serialization)

@@ 1,5 1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;


@@ 17,7 17,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix serialization)
-  #:use-module (guix utils)
+  #:use-module (guix combinators)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:use-module (srfi srfi-1)

@@ 19,6 19,7 @@
 (define-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix config)
+  #:use-module (guix combinators)
   #:use-module (guix serialization)
   #:use-module (guix monads)
   #:autoload   (guix base32) (bytevector->base32-string)

@@ 30,6 30,7 @@
   #:use-module (guix packages)
   #:use-module (guix profiles)
   #:use-module (guix derivations)
+  #:use-module (guix combinators)
   #:use-module (guix build-system)
   #:use-module (guix serialization)
   #:use-module ((guix build utils) #:select (mkdir-p))

@@ 32,6 32,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
+  #:use-module (guix combinators)
   #:use-module ((guix build utils) #:select (dump-port))
   #:use-module ((guix build syscalls) #:select (errno mkdtemp!))
   #:use-module (ice-9 vlist)


@@ 46,9 47,7 @@
   #:export (bytevector->base16-string
             base16-string->bytevector
 
-            compile-time-value
             fcntl-flock
-            memoize
             strip-keyword-arguments
             default-keyword-arguments
             substitute-keyword-arguments


@@ 82,9 81,6 @@
             call-with-temporary-output-file
             call-with-temporary-directory
             with-atomic-file-output
-            fold2
-            fold-tree
-            fold-tree-leaves
             cache-directory
             readlink*
             edit-expression


@@ 99,22 95,6 @@
 
 
 ;;;
-;;; Compile-time computations.
-;;;
-
-(define-syntax compile-time-value
-  (syntax-rules ()
-    "Evaluate the given expression at compile time.  The expression must
-evaluate to a simple datum."
-    ((_ exp)
-     (let-syntax ((v (lambda (s)
-                       (let ((val exp))
-                         (syntax-case s ()
-                           (_ #`'#,(datum->syntax s val)))))))
-       v))))
-
-
-;;;
 ;;; Base 16.
 ;;;
 


@@ 432,22 412,9 @@ exception if it's already taken."
 
 
 ;;;
-;;; Miscellaneous.
+;;; Keyword arguments.
 ;;;
 
-(define (memoize proc)
-  "Return a memoizing version of PROC."
-  (let ((cache (make-hash-table)))
-    (lambda args
-      (let ((results (hash-ref cache args)))
-        (if results
-            (apply values results)
-            (let ((results (call-with-values (lambda ()
-                                               (apply proc args))
-                             list)))
-              (hash-set! cache args results)
-              (apply values results)))))))
-
 (define (strip-keyword-arguments keywords args)
   "Remove all of the keyword arguments listed in KEYWORDS from ARGS."
   (let loop ((args   args)


@@ 533,6 500,11 @@ For instance:
          (#f
           (loop rest kw/values (cons* value kw result))))))))
 
+
+;;;
+;;; System strings.
+;;;
+
 (define* (nix-system->gnu-triplet
           #:optional (system (%current-system)) (vendor "unknown"))
   "Return a guess of the GNU triplet corresponding to Nix system


@@ 731,62 703,6 @@ output port, and PROC's result is returned."
       (lambda (key . args)
         (false-if-exception (delete-file template))))))
 
-(define fold2
-  (case-lambda
-    ((proc seed1 seed2 lst)
-     "Like `fold', but with a single list and two seeds."
-     (let loop ((result1 seed1)
-                (result2 seed2)
-                (lst     lst))
-       (if (null? lst)
-           (values result1 result2)
-           (call-with-values
-               (lambda () (proc (car lst) result1 result2))
-             (lambda (result1 result2)
-               (loop result1 result2 (cdr lst)))))))
-    ((proc seed1 seed2 lst1 lst2)
-     "Like `fold', but with a two lists and two seeds."
-     (let loop ((result1 seed1)
-                (result2 seed2)
-                (lst1    lst1)
-                (lst2    lst2))
-       (if (or (null? lst1) (null? lst2))
-           (values result1 result2)
-           (call-with-values
-               (lambda () (proc (car lst1) (car lst2) result1 result2))
-             (lambda (result1 result2)
-               (fold2 proc result1 result2 (cdr lst1) (cdr lst2)))))))))
-
-(define (fold-tree proc init children roots)
-  "Call (PROC NODE RESULT) for each node in the tree that is reachable from
-ROOTS, using INIT as the initial value of RESULT.  The order in which nodes
-are traversed is not specified, however, each node is visited only once, based
-on an eq? check.  Children of a node to be visited are generated by
-calling (CHILDREN NODE), the result of which should be a list of nodes that
-are connected to NODE in the tree, or '() or #f if NODE is a leaf node."
-  (let loop ((result init)
-             (seen vlist-null)
-             (lst roots))
-    (match lst
-      (() result)
-      ((head . tail)
-       (if (not (vhash-assq head seen))
-           (loop (proc head result)
-                 (vhash-consq head #t seen)
-                 (match (children head)
-                   ((or () #f) tail)
-                   (children (append tail children))))
-           (loop result seen tail))))))
-
-(define (fold-tree-leaves proc init children roots)
-  "Like fold-tree, but call (PROC NODE RESULT) only for leaf nodes."
-  (fold-tree
-   (lambda (node result)
-     (match (children node)
-       ((or () #f) (proc node result))
-       (else result)))
-   init children roots))
-
 (define (cache-directory)
   "Return the cache directory for Guix, by default ~/.cache/guix."
   (or (getenv "XDG_CONFIG_HOME")

@@ 0,0 1,85 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-combinators)
+  #:use-module (guix combinators)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-64)
+  #:use-module (ice-9 vlist))
+
+(test-begin "combinators")
+
+(test-equal "fold2, 1 list"
+    (list (reverse (iota 5))
+          (map - (reverse (iota 5))))
+  (call-with-values
+      (lambda ()
+        (fold2 (lambda (i r1 r2)
+                 (values (cons i r1)
+                         (cons (- i) r2)))
+               '() '()
+               (iota 5)))
+    list))
+
+(test-equal "fold2, 2 lists"
+    (list (reverse '((a . 0) (b . 1) (c . 2) (d . 3)))
+          (reverse '((a . 0) (b . -1) (c . -2) (d . -3))))
+  (call-with-values
+      (lambda ()
+        (fold2 (lambda (k v r1 r2)
+                 (values (alist-cons k v r1)
+                         (alist-cons k (- v) r2)))
+               '() '()
+               '(a b c d)
+               '(0 1 2 3)))
+    list))
+
+(let* ((tree (alist->vhash
+              '((0 2 3) (1 3 4) (2) (3 5 6) (4 6) (5) (6))
+              hashq))
+       (add-one (lambda (_ r) (1+ r)))
+       (tree-lookup (lambda (n) (cdr (vhash-assq n tree)))))
+  (test-equal "fold-tree, single root"
+    5 (fold-tree add-one 0 tree-lookup '(0)))
+  (test-equal "fold-tree, two roots"
+    7 (fold-tree add-one 0 tree-lookup '(0 1)))
+  (test-equal "fold-tree, sum"
+    16 (fold-tree + 0 tree-lookup '(0)))
+  (test-equal "fold-tree, internal"
+    18 (fold-tree + 0 tree-lookup '(3 4)))
+  (test-equal "fold-tree, cons"
+    '(1 3 4 5 6)
+    (sort (fold-tree cons '() tree-lookup '(1)) <))
+  (test-equal "fold-tree, overlapping paths"
+    '(1 3 4 5 6)
+    (sort (fold-tree cons '() tree-lookup '(1 4)) <))
+  (test-equal "fold-tree, cons, two roots"
+    '(0 2 3 4 5 6)
+    (sort (fold-tree cons '() tree-lookup '(0 4)) <))
+  (test-equal "fold-tree-leaves, single root"
+    2 (fold-tree-leaves add-one 0 tree-lookup '(1)))
+  (test-equal "fold-tree-leaves, single root, sum"
+    11 (fold-tree-leaves + 0 tree-lookup '(1)))
+  (test-equal "fold-tree-leaves, two roots"
+    3 (fold-tree-leaves add-one 0 tree-lookup '(0 1)))
+  (test-equal "fold-tree-leaves, two roots, sum"
+    13 (fold-tree-leaves + 0 tree-lookup '(0 1))))
+
+(test-end)
+

@@ 97,31 97,6 @@
         (string-replace-substring "/nix/store/chbouib" "/nix/" "/gnu/")
         (string-replace-substring "" "foo" "bar")))
 
-(test-equal "fold2, 1 list"
-    (list (reverse (iota 5))
-          (map - (reverse (iota 5))))
-  (call-with-values
-      (lambda ()
-        (fold2 (lambda (i r1 r2)
-                 (values (cons i r1)
-                         (cons (- i) r2)))
-               '() '()
-               (iota 5)))
-    list))
-
-(test-equal "fold2, 2 lists"
-    (list (reverse '((a . 0) (b . 1) (c . 2) (d . 3)))
-          (reverse '((a . 0) (b . -1) (c . -2) (d . -3))))
-  (call-with-values
-      (lambda ()
-        (fold2 (lambda (k v r1 r2)
-                 (values (alist-cons k v r1)
-                         (alist-cons k (- v) r2)))
-               '() '()
-               '(a b c d)
-               '(0 1 2 3)))
-    list))
-
 (test-equal "strip-keyword-arguments"
   '(a #:b b #:c c)
   (strip-keyword-arguments '(#:foo #:bar #:baz)


@@ 136,37 111,6 @@
         (ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
         (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))))
 
-(let* ((tree (alist->vhash
-              '((0 2 3) (1 3 4) (2) (3 5 6) (4 6) (5) (6))
-              hashq))
-       (add-one (lambda (_ r) (1+ r)))
-       (tree-lookup (lambda (n) (cdr (vhash-assq n tree)))))
-  (test-equal "fold-tree, single root"
-    5 (fold-tree add-one 0 tree-lookup '(0)))
-  (test-equal "fold-tree, two roots"
-    7 (fold-tree add-one 0 tree-lookup '(0 1)))
-  (test-equal "fold-tree, sum"
-    16 (fold-tree + 0 tree-lookup '(0)))
-  (test-equal "fold-tree, internal"
-    18 (fold-tree + 0 tree-lookup '(3 4)))
-  (test-equal "fold-tree, cons"
-    '(1 3 4 5 6)
-    (sort (fold-tree cons '() tree-lookup '(1)) <))
-  (test-equal "fold-tree, overlapping paths"
-    '(1 3 4 5 6)
-    (sort (fold-tree cons '() tree-lookup '(1 4)) <))
-  (test-equal "fold-tree, cons, two roots"
-    '(0 2 3 4 5 6)
-    (sort (fold-tree cons '() tree-lookup '(0 4)) <))
-  (test-equal "fold-tree-leaves, single root"
-    2 (fold-tree-leaves add-one 0 tree-lookup '(1)))
-  (test-equal "fold-tree-leaves, single root, sum"
-    11 (fold-tree-leaves + 0 tree-lookup '(1)))
-  (test-equal "fold-tree-leaves, two roots"
-    3 (fold-tree-leaves add-one 0 tree-lookup '(0 1)))
-  (test-equal "fold-tree-leaves, two roots, sum"
-    13 (fold-tree-leaves + 0 tree-lookup '(0 1))))
-
 (test-assert "filtered-port, file"
   (let* ((file  (search-path %load-path "guix.scm"))
          (input (open-file file "r0b")))