projects/guix·blob javascript-team · refs

168 lines · 6.0 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2012-2017, 2021, 2026 Ludovic Courtès <[email protected]>
3;;; Copyright © 2014 Eric Bavier <[email protected]>
4;;; Copyright © 2020 Arun Isaac <[email protected]>
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;;; Commentary:
22;;;
23;;; This module provides useful combinators that complement SRFI-1 and
24;;; friends.
25;;;
26;;; Code:
27
28(define-module (guix combinators)
29 #:use-module (ice-9 match)
30 #:use-module (ice-9 vlist)
31 #:export (given
32 fold2
33 fold-tree
34 fold-tree-leaves
35 compile-time-value
36 procedure-call-location
37 define-compile-time-procedure))
38
39;;; Commentary:
40;;;
41;;; This module provides useful combinators that complement SRFI-1 and
42;;; friends.
43;;;
44;;; Code:
45
46(define* (given pred consequent #:optional (alternate identity))
47 "Return a procedure that, for a given value V, returns:
48(if (pred v) (consequent v) (alternate v)). This is a higher-order 'if'."
49 ;; Racket calls this 'if?', which makes the parallel clear but breaks the
50 ;; convention of using question marks for predicates only. SRFI-235 doesn't
51 ;; have this.
52 (lambda (value)
53 (if (pred value)
54 (consequent value)
55 (alternate value))))
56
57(define fold2
58 (case-lambda
59 ((proc seed1 seed2 lst)
60 "Like `fold', but with a single list and two seeds."
61 (let loop ((result1 seed1)
62 (result2 seed2)
63 (lst lst))
64 (if (null? lst)
65 (values result1 result2)
66 (call-with-values
67 (lambda () (proc (car lst) result1 result2))
68 (lambda (result1 result2)
69 (loop result1 result2 (cdr lst)))))))
70 ((proc seed1 seed2 lst1 lst2)
71 "Like `fold', but with two lists and two seeds."
72 (let loop ((result1 seed1)
73 (result2 seed2)
74 (lst1 lst1)
75 (lst2 lst2))
76 (if (or (null? lst1) (null? lst2))
77 (values result1 result2)
78 (call-with-values
79 (lambda () (proc (car lst1) (car lst2) result1 result2))
80 (lambda (result1 result2)
81 (loop result1 result2 (cdr lst1) (cdr lst2)))))))))
82
83(define (fold-tree proc init children roots)
84 "Call (PROC NODE RESULT) for each node in the tree that is reachable from
85ROOTS, using INIT as the initial value of RESULT. The order in which nodes
86are traversed is not specified, however, each node is visited only once, based
87on an eq? check. Children of a node to be visited are generated by
88calling (CHILDREN NODE), the result of which should be a list of nodes that
89are connected to NODE in the tree, or '() or #f if NODE is a leaf node."
90 (let loop ((result init)
91 (seen vlist-null)
92 (lst roots))
93 (match lst
94 (() result)
95 ((head . tail)
96 (if (not (vhash-assq head seen))
97 (loop (proc head result)
98 (vhash-consq head #t seen)
99 (match (children head)
100 ((or () #f) tail)
101 (children (append tail children))))
102 (loop result seen tail))))))
103
104(define (fold-tree-leaves proc init children roots)
105 "Like fold-tree, but call (PROC NODE RESULT) only for leaf nodes."
106 (fold-tree
107 (lambda (node result)
108 (match (children node)
109 ((or () #f) (proc node result))
110 (else result)))
111 init children roots))
112
113(define-syntax compile-time-value ;not quite at home
114 (syntax-rules ()
115 "Evaluate the given expression at compile time. The expression must
116evaluate to a simple datum."
117 ((_ exp)
118 (let-syntax ((v (lambda (s)
119 (let ((val exp))
120 (syntax-case s ()
121 (_ #`'#,(datum->syntax s val)))))))
122 v))))
123
124(define-syntax-parameter procedure-call-location
125 (lambda (s)
126 (syntax-violation 'procedure-call-location
127 "'procedure-call-location' may only be used \
128within 'define-compile-time-procedure'"
129 s)))
130
131(define-syntax-rule (define-compile-time-procedure (proc (arg pred) ...)
132 body ...)
133 "Define PROC as a macro such that, if every actual argument in a \"call\"
134matches PRED, then BODY is evaluated at macro-expansion time. BODY must
135return a single value in a type that has read syntax--e.g., numbers, strings,
136lists, etc.
137
138BODY can refer to 'procedure-call-location', which is bound to a source
139property alist corresponding to the call site.
140
141This macro is meant to be used primarily for small procedures that validate or
142process its arguments in a way that may be equally well performed at
143macro-expansion time."
144 (define-syntax proc
145 (lambda (s)
146 (define loc
147 #`(identifier-syntax
148 '#,(datum->syntax #'s (syntax-source s))))
149
150 (syntax-case s ()
151 ((_ arg ...)
152 (and (pred (syntax->datum #'arg)) ...)
153 (let ((arg (syntax->datum #'arg)) ...)
154 (syntax-parameterize ((procedure-call-location
155 (identifier-syntax (syntax-source s))))
156 body ...)))
157 ((_ actual (... ...))
158 #`((lambda (arg ...)
159 (syntax-parameterize ((procedure-call-location #,loc))
160 body ...))
161 actual (... ...)))
162 (id
163 (identifier? #'id)
164 #`(lambda (arg ...)
165 (syntax-parameterize ((procedure-call-location #,loc))
166 body ...)))))))
167
168;;; combinators.scm ends here