132 lines
4.2 KiB
Racket
132 lines
4.2 KiB
Racket
#lang typed/racket
|
|
(require "typed-untyped.rkt")
|
|
(define-typed/untyped-modules #:no-test
|
|
(provide define-syntax/parse
|
|
λ/syntax-parse
|
|
~maybe
|
|
~lit
|
|
~or-bug
|
|
define-simple-macro
|
|
λstx
|
|
template/debug
|
|
quasitemplate/debug
|
|
meta-eval)
|
|
|
|
(require syntax/parse
|
|
syntax/parse/define
|
|
syntax/parse/experimental/template
|
|
(for-syntax racket/base
|
|
racket/syntax))
|
|
|
|
(define-syntax ~maybe
|
|
(pattern-expander
|
|
(λ (stx)
|
|
(syntax-parse stx
|
|
[(self pat ...)
|
|
(define (s stx) (datum->syntax #'self stx stx stx))
|
|
#`(#,(s #'~optional) (#,(s #'~seq) pat ...))]))))
|
|
|
|
;; Circumvent the bug that causes "syntax-parse: duplicate attribute in: a" in
|
|
;; (syntax-parse #'(x y z) [((~or a (a b c)) ...) #'(a ...)])
|
|
(define-syntax ~or-bug
|
|
(pattern-expander
|
|
(λ (stx)
|
|
(syntax-parse stx
|
|
[(self pat ...)
|
|
(define (s stx) (datum->syntax #'self stx stx stx))
|
|
#`(#,(s #'~and) x (#,(s #'~parse) (#,(s #'~or) pat ...) #'x))]))))
|
|
|
|
(define-syntax ~lit
|
|
(pattern-expander
|
|
(λ (stx)
|
|
(syntax-parse stx
|
|
[(self (~optional (~seq name:id (~literal ~))) lit)
|
|
(define (s stx) (datum->syntax #'self stx stx stx))
|
|
(if (attribute name)
|
|
#`(#,(s #'~and) name (#,(s #'~literal) lit))
|
|
#`(#,(s #'~literal) lit))]
|
|
[(self (~optional (~seq name:id (~literal ~))) lit …)
|
|
(define (s stx) (datum->syntax #'self stx stx stx))
|
|
(if (attribute name)
|
|
#`(#,(s #'~and) name (#,(s #'~seq) (#,(s #'~literal) lit)))
|
|
#`(#,(s #'~seq) (#,(s #'~literal) lit)))]))))
|
|
|
|
(begin-for-syntax
|
|
(require (for-syntax racket/base
|
|
racket/stxparam)
|
|
racket/stxparam)
|
|
|
|
(provide stx)
|
|
|
|
(define-syntax-parameter stx
|
|
(lambda (stx)
|
|
(raise-syntax-error (syntax-e stx)
|
|
"Can only be used in define-syntax/parse"))))
|
|
|
|
(define-simple-macro (define-syntax/parse (name . args) body0 . body)
|
|
(define-syntax (name stx2)
|
|
(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
|
|
(syntax-parse stx2
|
|
[(_ . args) body0 . body]))))
|
|
|
|
(define-simple-macro (λ/syntax-parse args . body)
|
|
(λ (stx2)
|
|
;(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
|
|
(syntax-parse stx2
|
|
[args . body])))
|
|
|
|
;; λstx
|
|
(begin
|
|
(define-syntax-rule (λstx (param ...) body ...)
|
|
(λ (param ...)
|
|
(with-syntax ([param param] ...)
|
|
body ...)))
|
|
|
|
(module+ test
|
|
(require typed/rackunit)
|
|
(check-equal? (syntax->datum ((λstx (foo bar) #'(foo bar)) #'a #'b))
|
|
(syntax->datum #'(a b)))))
|
|
|
|
;; template/debug
|
|
(begin
|
|
(define-syntax (template/debug stx)
|
|
(syntax-parse stx
|
|
[(_ debug-attribute:id . rest)
|
|
#'((λ (x)
|
|
(when (attribute debug-attribute)
|
|
(pretty-write (syntax->datum x)))
|
|
x)
|
|
(template . rest))])))
|
|
|
|
;; quasitemplate/debug
|
|
(begin
|
|
(define-syntax (quasitemplate/debug stx)
|
|
(syntax-parse stx
|
|
[(_ debug-attribute:id . rest)
|
|
#'((λ (x)
|
|
(when (attribute debug-attribute)
|
|
(pretty-write (syntax->datum x)))
|
|
x)
|
|
(quasitemplate . rest))])))
|
|
|
|
;; meta-eval
|
|
(begin
|
|
;; TODO: this is kind of a hack, as we have to write:
|
|
#;(with-syntax ([(x …) #'(a bb ccc)])
|
|
(let ([y 70])
|
|
(quasitemplate
|
|
([x (meta-eval (+ #,y (string-length
|
|
(symbol->string
|
|
(syntax-e #'x)))))]
|
|
…))))
|
|
;; Where we need #,y instead of using:
|
|
;; (+ y (string-length etc.)).
|
|
(module m-meta-eval racket
|
|
(provide meta-eval)
|
|
(require syntax/parse/experimental/template)
|
|
|
|
(define-template-metafunction (meta-eval stx)
|
|
(syntax-case stx ()
|
|
[(_ . body)
|
|
#`#,(eval #'(begin . body))])))
|
|
(require 'm-meta-eval))) |