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
|
#lang racket/base
(require racket/list
racket/contract)
; A dispatch pattern is either
; - a string
; - a bidi match expander
; - ...
(define (...? stx)
(eq? '... (syntax->datum stx)))
(define (string-syntax? stx)
(string? (syntax->datum stx)))
(define (dispatch-pattern? stx)
(define (dispatch/no-...? stx)
(syntax-case stx ()
[() #t]
[((bidi arg ...) . rest-stx)
(dispatch/...? #'rest-stx)]
[(string . rest-stx)
(string-syntax? #'string)
(dispatch/no-...? #'rest-stx)]))
(define (dispatch/...? stx)
(syntax-case stx ()
[() #t]
[((bidi arg ...) . rest-stx)
(dispatch/...? #'rest-stx)]
[(string . rest-stx)
(string-syntax? #'string)
(dispatch/no-...? #'rest-stx)]
[((... ...) . rest-stx)
(dispatch/no-...? #'rest-stx)]))
(dispatch/no-...? stx))
(define (dispatch-pattern/ids? stx)
(define (dispatch/no-...? stx)
(syntax-case stx ()
[() #t]
[((bidi arg ... id) . rest-stx)
(identifier? #'id)
(dispatch/...? #'rest-stx)]
[(string . rest-stx)
(string-syntax? #'string)
(dispatch/no-...? #'rest-stx)]))
(define (dispatch/...? stx)
(syntax-case stx ()
[() #t]
[((bidi arg ... id) . rest-stx)
(identifier? #'id)
(dispatch/...? #'rest-stx)]
[(string . rest-stx)
(string-syntax? #'string)
(dispatch/no-...? #'rest-stx)]
[((... ...) . rest-stx)
(dispatch/no-...? #'rest-stx)]))
(dispatch/no-...? stx))
(define (dispatch-pattern-not-... stx)
(filter (compose not ...?)
(syntax->list stx)))
(define (dispatch-pattern-next-...? stx)
(let loop ([l (syntax->list stx)])
(cond
[(empty? l)
empty]
[(empty? (rest l))
(list #f)]
[(...? (second l))
(list* #t (loop (rest (rest l))))]
[else
(list* #f (loop (rest l)))])))
(define (dispatch-pattern->dispatch-pattern/ids pps)
(map (lambda (pp ppi)
(cond
[(string-syntax? pp)
pp]
[(...? pp)
pp]
[else
(with-syntax ([(bidi-id arg ...) pp]
[id ppi])
(syntax/loc pp (bidi-id arg ... id)))]))
(syntax->list pps)
(generate-temporaries pps)))
(provide/contract
[string-syntax? (syntax? . -> . boolean?)]
[dispatch-pattern-next-...? (syntax? . -> . (listof boolean?))]
[dispatch-pattern-not-... (syntax? . -> . (listof syntax?))]
[dispatch-pattern->dispatch-pattern/ids (syntax? . -> . (listof syntax?))]
[dispatch-pattern? (syntax? . -> . boolean?)]
[dispatch-pattern/ids? (syntax? . -> . boolean?)])
|
