94 lines
2.6 KiB
Racket
94 lines
2.6 KiB
Racket
#lang racket
|
|
; 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?)])
|