1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
|
;;; ccwl --- Concise Common Workflow Language
;;; Copyright © 2021 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of ccwl.
;;;
;;; ccwl 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.
;;;
;;; ccwl 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 ccwl. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; A few useful utilities
;;; Code:
(define-module (ccwl utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:export (pairify
plist->alist
lambda**
syntax-lambda**
mapn
append-mapn
foldn
filter-mapi))
(define (pairify lst)
"Return a list of pairs of successive elements of LST."
(match lst
(() '())
((first second tail ...)
(cons (cons first second)
(pairify tail)))))
(define (plist->alist plist)
"Convert the property list PLIST to an association list. A property
list is a list of the form (#:key1 value1 #:key2 value2 ...)."
(map (match-lambda
((key . value)
(cons (keyword->symbol key) value)))
(pairify plist)))
(define* (group-keyword-arguments args #:optional (unary-keywords (list)))
"Group ARGS, a list of keyword arguments of arbitrary arity. Return
a list of unary keyword arguments. n-ary arguments are grouped
together into lists. Keywords that are to be treated as having unit
arity are listed in UNARY-KEYWORDS."
(match args
(((? (lambda (keyword)
(and (keyword? keyword)
(not (member keyword unary-keywords))))
this-keyword)
tail ...)
(let ((this-keyword-args tail (break keyword? tail)))
(cons* this-keyword
(apply list this-keyword-args)
(group-keyword-arguments tail unary-keywords))))
(((? (lambda (keyword)
(and (keyword? keyword)
(member keyword unary-keywords)))
this-keyword)
this-keyword-arg tail ...)
(cons* this-keyword this-keyword-arg
(group-keyword-arguments tail unary-keywords)))
((non-keyword _ ...)
(error "Invalid sequence of keywords arguments" args))
(() '())))
(define (plist-ref plist key)
"Return the value from the first entry in PLIST with the given KEY,
or #f if there is no such entry."
(match (find-tail (cut eq? key <>) plist)
((_ value . _) value)
(#f #f)))
(define (unsyntax-keywords lst)
"Unsyntax keywords in LST, a list of syntax objects. For example:
(unsyntax-keywords (list #'#:ham #'1 #'#:eggs #'2))
=> (#:ham #'1 #:eggs 2)"
(map (lambda (element)
(if (keyword? (syntax->datum element))
(syntax->datum element)
element))
lst))
;; TODO: Implement a define** for lambda** in the spirit of define*
;; for lambda*.
(define-syntax lambda**
(lambda (x)
"Define a lambda function that can have positional arguments
followed by unary and n-ary keyword arguments. Unary keyword arguments
are prefixed by #:key. n-ary keyword arguments are prefixed by
#:key*. For example:
(lambda** (a b #:key foo #:key* bar)
(list a b foo bar))
Here, a and b are positional arguments. foo is a unary keyword
argument. bar is an n-ary keyword argument. The above function could,
for example, be invoked as:
((lambda** (a b #:key foo #:key* bar)
(list a b foo bar))
1 2 #:foo 123 #:bar 1 2 3)
=> (1 2 123 (1 2 3))"
(syntax-case x ()
((_ (args-spec ...) body ...)
#`(lambda args
#,(let* ((args-spec (unsyntax-keywords #'(args-spec ...)))
(positionals rest (break keyword? args-spec))
(grouped-rest (group-keyword-arguments rest))
(unary-arguments (or (plist-ref grouped-rest #:key)
(list)))
(nary-arguments (or (plist-ref grouped-rest #:key*)
(list))))
#`(apply (lambda* #,(append positionals
(cons #:key (append unary-arguments nary-arguments)))
body ...)
(let ((positionals rest (break keyword? args)))
(append positionals
(group-keyword-arguments
rest (list #,@(map (compose symbol->keyword syntax->datum)
unary-arguments))))))))))))
(define-syntax-rule (syntax-lambda** formal-args body ...)
"Like lambda**, but for syntax objects. This is useful for writing
macros that accept keyword arguments."
(lambda (x)
(apply (lambda** formal-args body ...)
(with-ellipsis :::
(syntax-case x ()
((_ args :::)
(unsyntax-keywords #'(args :::))))))))
(define (filter-mapi proc lst)
"Indexed filter-map. Like filter-map, but PROC calls are (proc item
index) where ITEM is an element of list and INDEX is the index of that
element."
(filter-map (lambda (item index)
(proc item index))
lst
(iota (length lst))))
(define (mapn proc lst)
"Map the procedure PROC over list LST and return a list containing
the results. PROC can return multiple values, in which case, an equal
number of lists are returned."
(apply values
(apply zip
(map (lambda (x)
(call-with-values (cut proc x) list))
lst))))
(define (append-mapn proc lst)
"Map PROC over LST just as in mapn, but append the results
together. PROC can return multiple values, in which case, an equal
number of lists are returned."
(call-with-values (cut mapn proc lst)
(lambda lists
(apply values
(map (lambda (lst)
(apply append lst))
lists)))))
(define (foldn proc lst . inits)
"Apply PROC to the elements of LST to build a result, and return
that result. PROC can return multiple values, in which case, an equal
number of values are returned. Each PROC call is (PROC ELEMENT
PREVIOUS ...) where ELEMENT is an element of LST, and (PREVIOUS ...)
is the return from the previous call to PROC or the given INITS for
the first call."
(apply values
(fold (lambda (element results)
(call-with-values (cut apply proc element results) list))
inits
lst)))
|
