pattern-expander.rkt
This commit is contained in:
parent
d053edc101
commit
daba892a07
|
@ -0,0 +1,23 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(require auxiliary-macro-context)
|
||||||
|
|
||||||
|
(define-auxiliary-macro-context
|
||||||
|
#:context-name pattern-expander
|
||||||
|
#:prop-name prop:pattern-expander
|
||||||
|
#:prop-predicate-name pattern-expander?
|
||||||
|
#:prop-accessor-name pattern-expander-proc
|
||||||
|
#:macro-definer-name define-pattern-expander
|
||||||
|
#:introducer-parameter-name current-pattern-expander-introducer
|
||||||
|
#:local-introduce-name syntax-local-pattern-expander-introduce
|
||||||
|
#:expander-id-predicate-name pattern-expander-id?
|
||||||
|
#:expander-transform-name pattern-expander-transform)
|
||||||
|
|
||||||
|
(provide (for-syntax
|
||||||
|
prop:pattern-expander
|
||||||
|
pattern-expander?
|
||||||
|
pattern-expander-proc
|
||||||
|
syntax-local-pattern-expander-introduce
|
||||||
|
pattern-expander-id?
|
||||||
|
pattern-expander-transform)
|
||||||
|
define-pattern-expander)
|
|
@ -11,12 +11,15 @@
|
||||||
desc->skeleton-stx
|
desc->skeleton-stx
|
||||||
desc->capture-proj
|
desc->capture-proj
|
||||||
desc->capture-names
|
desc->capture-names
|
||||||
desc->assertion-stx))
|
desc->assertion-stx)
|
||||||
|
|
||||||
|
(all-from-out "pattern-expander.rkt"))
|
||||||
|
|
||||||
(require (for-syntax racket/base))
|
(require (for-syntax racket/base))
|
||||||
(require (for-syntax racket/match))
|
(require (for-syntax racket/match))
|
||||||
(require (for-syntax racket/struct-info))
|
(require (for-syntax racket/struct-info))
|
||||||
(require (for-syntax syntax/stx))
|
(require (for-syntax syntax/stx))
|
||||||
|
(require "pattern-expander.rkt")
|
||||||
|
|
||||||
(struct discard () #:prefab)
|
(struct discard () #:prefab)
|
||||||
(struct capture (detail) #:prefab)
|
(struct capture (detail) #:prefab)
|
||||||
|
@ -35,6 +38,9 @@
|
||||||
;; The other `SkProj` generates a second `SkKey` which is used as the
|
;; The other `SkProj` generates a second `SkKey` which is used as the
|
||||||
;; input to a handler function.
|
;; input to a handler function.
|
||||||
|
|
||||||
|
(define-for-syntax orig-insp
|
||||||
|
(variable-reference->module-declaration-inspector (#%variable-reference)))
|
||||||
|
|
||||||
(begin-for-syntax
|
(begin-for-syntax
|
||||||
(define (dollar-id? stx)
|
(define (dollar-id? stx)
|
||||||
(and (identifier? stx)
|
(and (identifier? stx)
|
||||||
|
@ -61,7 +67,14 @@
|
||||||
(free-identifier=? #'vector stx)))
|
(free-identifier=? #'vector stx)))
|
||||||
|
|
||||||
(define (analyse-pattern stx)
|
(define (analyse-pattern stx)
|
||||||
(syntax-case stx ($ quasiquote unquote quote)
|
(define disarmed-stx (syntax-disarm stx orig-insp))
|
||||||
|
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
||||||
|
[(expander args ...)
|
||||||
|
(pattern-expander-id? #'expander)
|
||||||
|
(pattern-expander-transform disarmed-stx
|
||||||
|
(lambda (result)
|
||||||
|
(analyse-pattern (syntax-rearm result stx))))]
|
||||||
|
|
||||||
;; Extremely limited support for quasiquoting and quoting
|
;; Extremely limited support for quasiquoting and quoting
|
||||||
[(quasiquote (unquote p)) (analyse-pattern #'p)]
|
[(quasiquote (unquote p)) (analyse-pattern #'p)]
|
||||||
[(quasiquote (p ...)) (analyse-pattern #'(list (quasiquote p) ...))]
|
[(quasiquote (p ...)) (analyse-pattern #'(list (quasiquote p) ...))]
|
||||||
|
@ -95,7 +108,14 @@
|
||||||
(list 'atom stx)]))
|
(list 'atom stx)]))
|
||||||
|
|
||||||
(define (instantiate-pattern->pattern stx)
|
(define (instantiate-pattern->pattern stx)
|
||||||
(syntax-case stx ($ quasiquote unquote quote)
|
(define disarmed-stx (syntax-disarm stx orig-insp))
|
||||||
|
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
||||||
|
[(expander args ...)
|
||||||
|
(pattern-expander-id? #'expander)
|
||||||
|
(pattern-expander-transform disarmed-stx
|
||||||
|
(lambda (result)
|
||||||
|
(instantiate-pattern->pattern (syntax-rearm result stx))))]
|
||||||
|
|
||||||
;; Extremely limited support for quasiquoting and quoting
|
;; Extremely limited support for quasiquoting and quoting
|
||||||
[(quasiquote (unquote p)) (instantiate-pattern->pattern #'p)]
|
[(quasiquote (unquote p)) (instantiate-pattern->pattern #'p)]
|
||||||
[(quasiquote (p ...)) (instantiate-pattern->pattern #'(list (quasiquote p) ...))]
|
[(quasiquote (p ...)) (instantiate-pattern->pattern #'(list (quasiquote p) ...))]
|
||||||
|
@ -123,7 +143,14 @@
|
||||||
#'other]))
|
#'other]))
|
||||||
|
|
||||||
(define (instantiate-pattern->value stx)
|
(define (instantiate-pattern->value stx)
|
||||||
(syntax-case stx ($ quasiquote unquote quote)
|
(define disarmed-stx (syntax-disarm stx orig-insp))
|
||||||
|
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
||||||
|
[(expander args ...)
|
||||||
|
(pattern-expander-id? #'expander)
|
||||||
|
(pattern-expander-transform disarmed-stx
|
||||||
|
(lambda (result)
|
||||||
|
(instantiate-pattern->value (syntax-rearm result stx))))]
|
||||||
|
|
||||||
;; Extremely limited support for quasiquoting and quoting
|
;; Extremely limited support for quasiquoting and quoting
|
||||||
[(quasiquote (unquote p)) (instantiate-pattern->pattern #'p)]
|
[(quasiquote (unquote p)) (instantiate-pattern->pattern #'p)]
|
||||||
[(quasiquote (p ...)) (instantiate-pattern->pattern #'(list (quasiquote p) ...))]
|
[(quasiquote (p ...)) (instantiate-pattern->pattern #'(list (quasiquote p) ...))]
|
||||||
|
|
|
@ -51,4 +51,18 @@
|
||||||
(foo (bar 'beep) $cap)
|
(foo (bar 'beep) $cap)
|
||||||
(s->d desc->assertion-stx))
|
(s->d desc->assertion-stx))
|
||||||
|
|
||||||
|
(define-pattern-expander foo123
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ zot) (foo 123 zot)]))
|
||||||
|
|
||||||
|
(define-pattern-expander foo234
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ zot) (foo 234 zot)])
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ zot) (foo 234 zot)]))
|
||||||
|
|
||||||
|
(check-analyse-pattern '(foo 123 'zot) (foo123 'zot))
|
||||||
|
(check-analyse-pattern '(foo 234 'zot) (foo234 'zot))
|
||||||
|
(check-equal? (foo 234 'zot) (foo234 'zot))
|
||||||
|
|
||||||
)
|
)
|
||||||
|
|
Loading…
Reference in New Issue