From 958dd3ce68733bcd5c1231424c7e4ad39e67594a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 4 May 2016 17:35:47 +0200
Subject: 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.
---
 guix/combinators.scm | 116 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 116 insertions(+)
 create mode 100644 guix/combinators.scm

(limited to 'guix/combinators.scm')

diff --git a/guix/combinators.scm b/guix/combinators.scm
new file mode 100644
index 0000000000..9e4689ba9c
--- /dev/null
+++ b/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
-- 
cgit v1.2.3