Browse Source

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.
gn-latest-20200428
Ludovic Courtès 6 years ago
parent
commit
958dd3ce68
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
  1. 2
      Makefile.am
  2. 1
      gnu/packages.scm
  3. 3
      gnu/packages/bootstrap.scm
  4. 2
      gnu/services/herd.scm
  5. 1
      guix/build-system/gnu.scm
  6. 1
      guix/build-system/python.scm
  7. 116
      guix/combinators.scm
  8. 1
      guix/derivations.scm
  9. 3
      guix/gnu-maintenance.scm
  10. 4
      guix/import/elpa.scm
  11. 1
      guix/scripts/archive.scm
  12. 1
      guix/scripts/build.scm
  13. 2
      guix/scripts/graph.scm
  14. 1
      guix/scripts/lint.scm
  15. 2
      guix/scripts/size.scm
  16. 1
      guix/scripts/substitute.scm
  17. 4
      guix/serialization.scm
  18. 1
      guix/store.scm
  19. 1
      guix/ui.scm
  20. 98
      guix/utils.scm
  21. 85
      tests/combinators.scm
  22. 56
      tests/utils.scm

2
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 \

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

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

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

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

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

116
guix/combinators.scm

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

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

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

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

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

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

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

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

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

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

4
guix/serialization.scm

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

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

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

98
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
@ -97,22 +93,6 @@
call-with-compressed-output-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.
@ -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")

85
tests/combinators.scm

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

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

Loading…
Cancel
Save