Browse Source
* 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.version-0.11.0

22 changed files with 231 additions and 156 deletions
@ -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 |
@ -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) |
|||
|
Loading…
Reference in new issue