mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
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:
parent
4b6fa8b339
commit
958dd3ce68
22 changed files with 231 additions and 156 deletions
|
@ -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 \
|
||||||
|
|
|
@ -24,6 +24,7 @@ (define-module (gnu packages)
|
||||||
#: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)))
|
||||||
|
|
|
@ -27,7 +27,8 @@ (define-module (gnu packages bootstrap)
|
||||||
#: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)
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
116
guix/combinators.scm
Normal 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
|
|
@ -30,6 +30,7 @@ (define-module (guix derivations)
|
||||||
#: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)
|
||||||
|
|
|
@ -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 @@ (define-module (guix gnu-maintenance)
|
||||||
#: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)
|
||||||
|
|
|
@ -35,8 +35,8 @@ (define-module (guix import elpa)
|
||||||
#: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))
|
||||||
|
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -24,6 +24,7 @@ (define-module (guix scripts build)
|
||||||
#: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))
|
||||||
|
|
|
@ -21,7 +21,7 @@ (define-module (guix scripts graph)
|
||||||
#: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)
|
||||||
|
|
|
@ -31,6 +31,7 @@ (define-module (guix scripts lint)
|
||||||
#: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)
|
||||||
|
|
|
@ -21,7 +21,7 @@ (define-module (guix scripts size)
|
||||||
#: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)
|
||||||
|
|
|
@ -21,6 +21,7 @@ (define-module (guix scripts substitute)
|
||||||
#: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)
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -30,6 +30,7 @@ (define-module (guix ui)
|
||||||
#: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))
|
||||||
|
|
|
@ -32,6 +32,7 @@ (define-module (guix utils)
|
||||||
#: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 @@ (define-module (guix utils)
|
||||||
#: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 @@ (define-module (guix utils)
|
||||||
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 @@ (define-module (guix utils)
|
||||||
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 @@ (define fd
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; 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 @@ (define (ensure-keyword-arguments args kw/values)
|
||||||
(#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 @@ (define (with-atomic-file-output file proc)
|
||||||
(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
85
tests/combinators.scm
Normal 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)
|
||||||
|
|
|
@ -97,31 +97,6 @@ (define temp-file
|
||||||
(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 @@ (define temp-file
|
||||||
(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")))
|
||||||
|
|
Loading…
Reference in a new issue