1#lang racket/base
2
3(require (for-syntax racket/base
4                     racket/syntax
5                     syntax/parse
6                     racket/list)
7         racket/list)
8
9(provide define-parameter-group parameterize/group parameterize*/group)
10
11(begin-for-syntax
12  (struct parameter-group (ids) #:transparent
13    #:property prop:procedure
14    (λ (g stx)
15      (syntax-case stx ()
16        [(_)
17         (with-syntax ([(ids ...)  (parameter-group-ids g)])
18           (syntax/loc stx
19             (list (ids) ...)))]))))
20
21(define-syntax (define-parameter-group stx)
22  (syntax-parse stx
23    [(_ name:id (param:id ...))
24     (syntax/loc stx
25       (define-syntax name (parameter-group (list #'param ...))))]))
26
27(define-for-syntax (make-list-ref val i)
28  (cond [(= i 0)  #`(car #,val)]
29        [else  (make-list-ref #`(cdr #,val) (- i 1))]))
30
31(define-for-syntax (expand-parameter-groups id val)
32  (define group (syntax-local-value id (λ () #f)))
33  (if (and group (parameter-group? group))
34      (let ([ids  (parameter-group-ids group)])
35        (append*
36         (map (λ (id i) (expand-parameter-groups id (make-list-ref val i)))
37              ids
38              (build-list (length ids) values))))
39      (list #`[#,id #,val])))
40
41;; Corresponds to parameterize
42(define-syntax (parameterize/group stx)
43  (syntax-parse stx
44    [(_ ([p:id v] ...) . body)
45     (with-syntax* ([(v-name ...)  (generate-temporaries #'(v ...))]
46                    [([p new-v] ...)  (append* (map expand-parameter-groups
47                                                    (syntax->list #'(p ...))
48                                                    (syntax->list #'(v-name ...))))])
49       (syntax/loc stx
50         (let ([v-name v] ...)
51           (parameterize ([p new-v] ...) . body))))]))
52
53;; Corresponds to parameterize*
54(define-syntax parameterize*/group
55  (syntax-rules ()
56      [(_ () . body)
57       (let () . body)]
58      [(_ ([lhs1 rhs1] [lhs rhs] ...) . body)
59       (parameterize/group ([lhs1 rhs1]) (parameterize*/group ([lhs rhs] ...) . body))]))
60