nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Ludovic Courtès 2016-05-04 17:35:47 +02:00
parent 4b6fa8b339
commit 958dd3ce68
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
22 changed files with 231 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile.am
View File

@ -38,6 +38,7 @@ MODULES = \
guix/hash.scm \ guix/hash.scm \
guix/pk-crypto.scm \ guix/pk-crypto.scm \
guix/pki.scm \ guix/pki.scm \
guix/combinators.scm \
guix/utils.scm \ guix/utils.scm \
guix/sets.scm \ guix/sets.scm \
guix/download.scm \ guix/download.scm \
@ -231,6 +232,7 @@ SCM_TESTS = \
tests/ui.scm \ tests/ui.scm \
tests/records.scm \ tests/records.scm \
tests/upstream.scm \ tests/upstream.scm \
tests/combinators.scm \
tests/utils.scm \ tests/utils.scm \
tests/build-utils.scm \ tests/build-utils.scm \
tests/packages.scm \ tests/packages.scm \

1
gnu/packages.scm
View File

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

3
gnu/packages/bootstrap.scm
View File

@ -27,7 +27,8 @@
#:use-module (guix build-system trivial) #:use-module (guix build-system trivial)
#:use-module ((guix store) #:select (add-to-store add-text-to-store)) #:use-module ((guix store) #:select (add-to-store add-text-to-store))
#:use-module ((guix derivations) #:select (derivation)) #: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-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (ice-9 match) #:use-module (ice-9 match)

2
gnu/services/herd.scm
View File

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

1
guix/build-system/gnu.scm
View File

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

1
guix/build-system/python.scm
View File

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

116
guix/combinators.scm Normal file
View File

@ -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

1
guix/derivations.scm
View File

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

3
guix/gnu-maintenance.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -30,6 +30,7 @@
#:use-module (guix http-client) #:use-module (guix http-client)
#:use-module (guix ftp-client) #:use-module (guix ftp-client)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix combinators)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix upstream) #:use-module (guix upstream)
#:use-module (guix packages) #:use-module (guix packages)

4
guix/import/elpa.scm
View File

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

1
guix/scripts/archive.scm
View File

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

1
guix/scripts/build.scm
View File

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

2
guix/scripts/graph.scm
View File

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

1
guix/scripts/lint.scm
View File

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

2
guix/scripts/size.scm
View File

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

1
guix/scripts/substitute.scm
View File

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

4
guix/serialization.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -17,7 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix serialization) (define-module (guix serialization)
#:use-module (guix utils) #:use-module (guix combinators)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)

1
guix/store.scm
View File

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

1
guix/ui.scm
View File

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

98
guix/utils.scm
View File

@ -32,6 +32,7 @@
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
#:use-module (guix combinators)
#:use-module ((guix build utils) #:select (dump-port)) #:use-module ((guix build utils) #:select (dump-port))
#:use-module ((guix build syscalls) #:select (errno mkdtemp!)) #:use-module ((guix build syscalls) #:select (errno mkdtemp!))
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
@ -46,9 +47,7 @@
#:export (bytevector->base16-string #:export (bytevector->base16-string
base16-string->bytevector base16-string->bytevector
compile-time-value
fcntl-flock fcntl-flock
memoize
strip-keyword-arguments strip-keyword-arguments
default-keyword-arguments default-keyword-arguments
substitute-keyword-arguments substitute-keyword-arguments
@ -82,9 +81,6 @@
call-with-temporary-output-file call-with-temporary-output-file
call-with-temporary-directory call-with-temporary-directory
with-atomic-file-output with-atomic-file-output
fold2
fold-tree
fold-tree-leaves
cache-directory cache-directory
readlink* readlink*
edit-expression edit-expression
@ -97,22 +93,6 @@
call-with-compressed-output-port call-with-compressed-output-port
canonical-newline-port)) canonical-newline-port))
;;;
;;; 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. ;;; 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) (define (strip-keyword-arguments keywords args)
"Remove all of the keyword arguments listed in KEYWORDS from ARGS." "Remove all of the keyword arguments listed in KEYWORDS from ARGS."
(let loop ((args args) (let loop ((args args)
@ -533,6 +500,11 @@ For instance:
(#f (#f
(loop rest kw/values (cons* value kw result)))))))) (loop rest kw/values (cons* value kw result))))))))
;;;
;;; System strings.
;;;
(define* (nix-system->gnu-triplet (define* (nix-system->gnu-triplet
#:optional (system (%current-system)) (vendor "unknown")) #:optional (system (%current-system)) (vendor "unknown"))
"Return a guess of the GNU triplet corresponding to Nix system "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) (lambda (key . args)
(false-if-exception (delete-file template)))))) (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) (define (cache-directory)
"Return the cache directory for Guix, by default ~/.cache/guix." "Return the cache directory for Guix, by default ~/.cache/guix."
(or (getenv "XDG_CONFIG_HOME") (or (getenv "XDG_CONFIG_HOME")

85
tests/combinators.scm Normal file
View File

@ -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)

56
tests/utils.scm
View File

@ -97,31 +97,6 @@
(string-replace-substring "/nix/store/chbouib" "/nix/" "/gnu/") (string-replace-substring "/nix/store/chbouib" "/nix/" "/gnu/")
(string-replace-substring "" "foo" "bar"))) (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" (test-equal "strip-keyword-arguments"
'(a #:b b #:c c) '(a #:b b #:c c)
(strip-keyword-arguments '(#:foo #:bar #:baz) (strip-keyword-arguments '(#:foo #:bar #:baz)
@ -136,37 +111,6 @@
(ensure-keyword-arguments '(#:foo 2) '(#:bar 3)) (ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
(ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42)))) (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" (test-assert "filtered-port, file"
(let* ((file (search-path %load-path "guix.scm")) (let* ((file (search-path %load-path "guix.scm"))
(input (open-file file "r0b"))) (input (open-file file "r0b")))