blob: 912fd1648fc9b45564a7e9702a9e23a470de83f3 (
plain)
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
|
(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 (lambda**))
(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)))
;; 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* ((positionals rest (break keyword? (syntax->datum #'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* #,(datum->syntax x (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 (cut datum->syntax x <>)
symbol->keyword)
unary-arguments))))))))))))
|
