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.
master
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/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
View File

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

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

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

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

@ -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 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 (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
View File

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

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

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

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

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

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

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

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

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

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

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

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