[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
04/09: utils: Move combinators to (guix combinators).
|
From: |
Ludovic Courtès |
|
Subject: |
04/09: utils: Move combinators to (guix combinators). |
|
Date: |
Wed, 04 May 2016 21:37:21 +0000 |
civodul pushed a commit to branch master
in repository guix.
commit 958dd3ce68733bcd5c1231424c7e4ad39e67594a
Author: Ludovic Courtès <address@hidden>
Date: Wed May 4 17:35:47 2016 +0200
utils: Move combinators to (guix combinators).
* guix/utils.scm (compile-time-value, memoize, fold2)
(fold-tree, fold-tree-leaves): Move to...
* guix/combinators: ... here. New file.
* tests/utils.scm ("fold2, 1 list", "fold2, 2 lists")
(fold-tree tests): Move to...
* tests/combinators.scm: ... here. New file.
* Makefile.am (MODULES, SCM_TESTS): Add them.
* gnu/packages.scm, gnu/packages/bootstrap.scm,
gnu/services/herd.scm, guix/build-system/gnu.scm,
guix/build-system/python.scm, guix/derivations.scm,
guix/gnu-maintenance.scm, guix/import/elpa.scm,
guix/scripts/archive.scm, guix/scripts/build.scm,
guix/scripts/graph.scm, guix/scripts/lint.scm,
guix/scripts/size.scm, guix/scripts/substitute.scm,
guix/serialization.scm, guix/store.scm, guix/ui.scm: Adjust imports
accordingly.
---
Makefile.am | 2 +
gnu/packages.scm | 1 +
gnu/packages/bootstrap.scm | 3 +-
gnu/services/herd.scm | 2 +-
guix/build-system/gnu.scm | 1 +
guix/build-system/python.scm | 1 +
guix/combinators.scm | 116 ++++++++++++++++++++++++++++++++++++++++++
guix/derivations.scm | 1 +
guix/gnu-maintenance.scm | 3 +-
guix/import/elpa.scm | 4 +-
guix/scripts/archive.scm | 1 +
guix/scripts/build.scm | 1 +
guix/scripts/graph.scm | 2 +-
guix/scripts/lint.scm | 1 +
guix/scripts/size.scm | 2 +-
guix/scripts/substitute.scm | 1 +
guix/serialization.scm | 4 +-
guix/store.scm | 1 +
guix/ui.scm | 1 +
guix/utils.scm | 98 +++--------------------------------
tests/combinators.scm | 85 +++++++++++++++++++++++++++++++
tests/utils.scm | 56 --------------------
22 files changed, 231 insertions(+), 156 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index d0c1826..4685fe1 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -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 \
diff --git a/gnu/packages.scm b/gnu/packages.scm
index 1e3f383..7130f58 100644
--- a/gnu/packages.scm
+++ b/gnu/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)))
diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm
index a3cd185..6a4eba9 100644
--- a/gnu/packages/bootstrap.scm
+++ b/gnu/packages/bootstrap.scm
@@ -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)
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index c06e988..7a9db90 100644
--- a/gnu/services/herd.scm
+++ b/gnu/services/herd.scm
@@ -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)
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index a7d1952..f6df183 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -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)
diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm
index 326e6fd..c3d6c62 100644
--- a/guix/build-system/python.scm
+++ b/guix/build-system/python.scm
@@ -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)
diff --git a/guix/combinators.scm b/guix/combinators.scm
new file mode 100644
index 0000000..9e4689b
--- /dev/null
+++ b/guix/combinators.scm
@@ -0,0 +1,116 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014 Eric Bavier <address@hidden>
+;;;
+;;; 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
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 2d8584e..d4f6974 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -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)
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 8021d99..adb62aa 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès
<address@hidden>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès
<address@hidden>
;;; Copyright © 2012, 2013 Nikita Karetnikov <address@hidden>
;;;
;;; 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)
diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index ccc4063..320a09e 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -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))
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 3fb210e..e06c38a 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -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)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 9a6b427..320ec39 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -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))
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index b0d7c08..ba63780 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -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)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index c581586..06001d3 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -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)
diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm
index 8f0cb7d..be1e8ca 100644
--- a/guix/scripts/size.scm
+++ b/guix/scripts/size.scm
@@ -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)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 1cfab81..d46d610 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -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)
diff --git a/guix/serialization.scm b/guix/serialization.scm
index 7a3defc..286b4cb 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
;;;
;;; 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)
diff --git a/guix/store.scm b/guix/store.scm
index 8d1099d..f352a99 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -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)
diff --git a/guix/ui.scm b/guix/ui.scm
index 04ac437..8310974 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -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))
diff --git a/guix/utils.scm b/guix/utils.scm
index 725f434..f18bbd1 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -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")
diff --git a/tests/combinators.scm b/tests/combinators.scm
new file mode 100644
index 0000000..1e4bb23
--- /dev/null
+++ b/tests/combinators.scm
@@ -0,0 +1,85 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014 Eric Bavier <address@hidden>
+;;;
+;;; 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)
+
diff --git a/tests/utils.scm b/tests/utils.scm
index 854999f..a54482e 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -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")))
- branch master updated (af5640d -> e9f693d), Ludovic Courtès, 2016/05/04
- 06/09: gnu: java-qdox: Escape "@" in description., Ludovic Courtès, 2016/05/04
- 02/09: environment: Use 'break' instead of 'split'., Ludovic Courtès, 2016/05/04
- 03/09: utils: Remove 'split'., Ludovic Courtès, 2016/05/04
- 05/09: build: Preserve stderr for shell tests., Ludovic Courtès, 2016/05/04
- 01/09: services: herd: Move UI handling to 'guix system'., Ludovic Courtès, 2016/05/04
- 07/09: system: Add procedures to access user accounts and service names., Ludovic Courtès, 2016/05/04
- 08/09: Add (gnu tests) and (gnu build marionette)., Ludovic Courtès, 2016/05/04
- 09/09: tests: Add whole-system test., Ludovic Courtès, 2016/05/04
- 04/09: utils: Move combinators to (guix combinators).,
Ludovic Courtès <=