guix/combinators.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
   4 ;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix combinators)
  22   #:use-module (ice-9 match)
  23   #:use-module (ice-9 vlist)
  24   #:export (fold2
  25             fold-tree
  26             fold-tree-leaves
  27             compile-time-value))
  28
  29 ;;; Commentary:
  30 ;;;
  31 ;;; This module provides useful combinators that complement SRFI-1 and
  32 ;;; friends.
  33 ;;;
  34 ;;; Code:
  35
  36 (define fold2
  37   (case-lambda
  38     ((proc seed1 seed2 lst)
  39      "Like `fold', but with a single list and two seeds."
  40      (let loop ((result1 seed1)
  41                 (result2 seed2)
  42                 (lst     lst))
  43        (if (null? lst)
  44            (values result1 result2)
  45            (call-with-values
  46                (lambda () (proc (car lst) result1 result2))
  47              (lambda (result1 result2)
  48                (loop result1 result2 (cdr lst)))))))
  49     ((proc seed1 seed2 lst1 lst2)
  50      "Like `fold', but with two lists and two seeds."
  51      (let loop ((result1 seed1)
  52                 (result2 seed2)
  53                 (lst1    lst1)
  54                 (lst2    lst2))
  55        (if (or (null? lst1) (null? lst2))
  56            (values result1 result2)
  57            (call-with-values
  58                (lambda () (proc (car lst1) (car lst2) result1 result2))
  59              (lambda (result1 result2)
  60                (loop result1 result2 (cdr lst1) (cdr lst2)))))))))
  61
  62 (define (fold-tree proc init children roots)
  63   "Call (PROC NODE RESULT) for each node in the tree that is reachable from
  64 ROOTS, using INIT as the initial value of RESULT.  The order in which nodes
  65 are traversed is not specified, however, each node is visited only once, based
  66 on an eq? check.  Children of a node to be visited are generated by
  67 calling (CHILDREN NODE), the result of which should be a list of nodes that
  68 are connected to NODE in the tree, or '() or #f if NODE is a leaf node."
  69   (let loop ((result init)
  70              (seen vlist-null)
  71              (lst roots))
  72     (match lst
  73       (() result)
  74       ((head . tail)
  75        (if (not (vhash-assq head seen))
  76            (loop (proc head result)
  77                  (vhash-consq head #t seen)
  78                  (match (children head)
  79                    ((or () #f) tail)
  80                    (children (append tail children))))
  81            (loop result seen tail))))))
  82
  83 (define (fold-tree-leaves proc init children roots)
  84   "Like fold-tree, but call (PROC NODE RESULT) only for leaf nodes."
  85   (fold-tree
  86    (lambda (node result)
  87      (match (children node)
  88        ((or () #f) (proc node result))
  89        (else result)))
  90    init children roots))
  91
  92 (define-syntax compile-time-value                 ;not quite at home
  93   (syntax-rules ()
  94     "Evaluate the given expression at compile time.  The expression must
  95 evaluate to a simple datum."
  96     ((_ exp)
  97      (let-syntax ((v (lambda (s)
  98                        (let ((val exp))
  99                          (syntax-case s ()
 100                            (_ #`'#,(datum->syntax s val)))))))
 101        v))))
 102
 103 ;;; combinators.scm ends here