Hi All,
Is there a simpler way of defining the syntax transformation (macro) below?
/Jens Axel
#lang racket
(require (for-syntax syntax/parse racket/syntax))
(provide let-match-expander)
;;; SYNTAX (let-match-expander ([id proc0 proc1] ...) body ...)
;;; (let-match-expander ([id proc0] ...) body ...)
;;; Bind id ... to a match expanders in body ...
;;; The procedure sub-expressions proc0 and proc1 are similar to
;;; the procedure sub-expressions of define-match-expander.
;;; EXPANSION STRATEGY
;;; Use define-match-expander to bind the match-expanders to fresh names.
;;; Use let-syntax to bind them in the body.
(define-syntax (let-match-expander stx)
; the procs attribute of optional-proc1 will always be a list,
; which means that we can use proc1.procs ... in a template
(define-splicing-syntax-class optional-proc1
(pattern (~seq proc1:expr) #:with procs #'(proc1))
(pattern (~seq) #:with procs #'()))
(syntax-parse stx
[(_let-match-expander ((~and clause [id:id proc0:expr
proc1:optional-proc1]) ...) body ...+)
;; For each identifier id we need a fresh name:
(define fresh-names (generate-temporaries #'(id ...)))
(with-syntax ([(fresh-name ...) fresh-names]
[((proc ...) ...) #'(proc1.procs ...)])
(syntax/loc stx
(begin
;; define a match expander for each id
(define-match-expander fresh-name proc0 proc ...) ...
;; make the match expander known inside the body
(let-syntax ([id (syntax-local-value #'fresh-name)] ...)
body ...))))]
;; catch various errors:
;; - missing body
[(_let-match-expander ((~and clause [id proc0 proc1:optional-proc1])
...))
(raise-syntax-error 'let-match-expander "bad syntax (missing body)"
stx)]
;; - wrong binding clause
[(_let-match-expander (clause ...) body ...)
(for ([c (syntax->list #'(clause ...))])
(syntax-parse c
[(id:id proc0:expr (~optional proc1:expr)) 'ok]
[_ (raise-syntax-error
'let-match-expander
"expected clause of the form [id proc-expr] or [id proc0-expr
proc1-expr]" c)]))
(raise-syntax-error 'let-match-expander "bad syntax" stx)]))
(module+ test (require rackunit)
(let-match-expander
([foo (λ (pat) (syntax-parse pat [(_foo f ...) #'(list f ...)]))
(λ (stx) #'42)]
[bar (λ (pat) (syntax-parse pat [(_bar f ...) #'(vector f ...)]))])
(check-equal? (match (list 1 2 3) [(foo a b c) (vector a b c)]) '#(1 2
3))
(check-equal? (foo) 42)
(check-equal? (match (vector 1 2 3)
[(foo a b c) (vector a b c)]
[(bar a b c) (list a b c)])
'(1 2 3))))
--
You received this message because you are subscribed to the Google Groups
"Racket Users" group.
To unsubscribe from this group and stop receiving emails from it, send an email
to racket-users+unsubscr...@googlegroups.com.
For more options, visit https://groups.google.com/d/optout.
