Add prop:match-expander' and prop:legacy-match-expander'.
This commit is contained in:
Sam Tobin-Hochstadt
parent
81dd112f57
commit
591dcc4a27
|
|
@ -6,14 +6,17 @@
|
|||
(only-in "match-expander.rkt"
|
||||
define-match-expander)
|
||||
"define-forms.rkt"
|
||||
"struct.rkt"
|
||||
"struct.rkt"
|
||||
(for-syntax "parse.rkt"
|
||||
(only-in "patterns.rkt" match-...-nesting)))
|
||||
(only-in "patterns.rkt"
|
||||
match-...-nesting
|
||||
prop:match-expander prop:legacy-match-expander)))
|
||||
|
||||
(provide (for-syntax match-...-nesting)
|
||||
(provide (for-syntax match-...-nesting
|
||||
prop:match-expander prop:legacy-match-expander)
|
||||
match-equality-test
|
||||
define-match-expander
|
||||
struct* ==
|
||||
struct* ==
|
||||
exn:misc:match?)
|
||||
|
||||
(define-forms parse
|
||||
|
|
|
|||
|
|
@ -138,13 +138,16 @@
|
|||
error-msg)
|
||||
(let* ([expander* (syntax-local-value expander)]
|
||||
[transformer (accessor expander*)]
|
||||
;; this transformer might have been defined w/ `syntax-id-rules'
|
||||
[transformer (if (set!-transformer? transformer)
|
||||
(set!-transformer-procedure transformer)
|
||||
transformer)])
|
||||
(unless transformer (raise-syntax-error #f error-msg expander*))
|
||||
(let* ([introducer (make-syntax-introducer)]
|
||||
[mstx (introducer (syntax-local-introduce stx))]
|
||||
[mresult (transformer mstx)]
|
||||
[mresult (if (procedure-arity-includes? transformer 2)
|
||||
(transformer expander* mstx)
|
||||
(transformer mstx))]
|
||||
[result (syntax-local-introduce (introducer mresult))])
|
||||
;(emit-local-step stx result #:id expander)
|
||||
(parse result))))
|
||||
|
|
|
|||
|
|
@ -18,10 +18,10 @@
|
|||
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
[(expander args ...)
|
||||
(and (identifier? #'expander)
|
||||
(match-expander?
|
||||
(syntax-local-value #'expander (lambda () #f))))
|
||||
(legacy-match-expander?
|
||||
(syntax-local-value #'expander (λ () #f))))
|
||||
(match-expander-transform
|
||||
parse #'expander disarmed-stx match-expander-legacy-xform
|
||||
parse #'expander disarmed-stx legacy-match-expander-proc
|
||||
"This expander only works with the standard match syntax")]
|
||||
[(and p ...)
|
||||
(make-And (map parse (syntax->list #'(p ...))))]
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@
|
|||
(match-expander? (syntax-local-value #'expander
|
||||
(lambda () #f))))
|
||||
(match-expander-transform
|
||||
rearm+parse #'expander disarmed-stx match-expander-match-xform
|
||||
rearm+parse #'expander disarmed-stx match-expander-proc
|
||||
"This expander only works with the legacy match syntax")]
|
||||
[(var v)
|
||||
(identifier? #'v)
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require syntax/boundmap
|
||||
scheme/contract
|
||||
(for-syntax scheme/base))
|
||||
racket/contract
|
||||
(for-syntax racket/base))
|
||||
|
||||
(provide (except-out (all-defined-out)
|
||||
struct-key-ht
|
||||
|
|
@ -208,20 +208,45 @@
|
|||
[vars-seen (listof (cons/c identifier?
|
||||
identifier?))])))
|
||||
|
||||
(define-struct match-expander (match-xform legacy-xform macro-xform)
|
||||
#| #:property prop:procedure (lambda (me stx)
|
||||
(define xf (match-expander-macro-xform me))
|
||||
(define xf* (if (set!-transformer? xf)
|
||||
(set!-transformer-procedure xf)
|
||||
xf))
|
||||
(xf* stx))|#
|
||||
#:property prop:set!-transformer (lambda (me stx)
|
||||
(define xf (match-expander-macro-xform me))
|
||||
(if (set!-transformer? xf)
|
||||
((set!-transformer-procedure xf) stx)
|
||||
(syntax-case stx (set!)
|
||||
[(set! . _)
|
||||
(raise-syntax-error #f "cannot mutate syntax identifier" stx)]
|
||||
[_ (xf stx)]))))
|
||||
|
||||
(provide (struct-out match-expander))
|
||||
(struct acc-prop (n acc))
|
||||
(define (make-struct-type-property/accessor name [guard #f] [supers null])
|
||||
(define-values (p pred? acc)
|
||||
(make-struct-type-property name
|
||||
(λ (pval sinfo)
|
||||
(cond [(exact-nonnegative-integer? pval)
|
||||
(acc-prop pval (cadddr sinfo))]
|
||||
[else (if (procedure? guard)
|
||||
(guard pval sinfo)
|
||||
pval)]))
|
||||
supers))
|
||||
(values p pred? (lambda (v)
|
||||
(define v* (acc v))
|
||||
(if (acc-prop? v*)
|
||||
((acc-prop-acc v*) v (acc-prop-n v*))
|
||||
v*))))
|
||||
|
||||
(define-values (prop:match-expander match-expander? match-expander-proc)
|
||||
(make-struct-type-property/accessor 'prop:match-expander))
|
||||
|
||||
(define-values (prop:legacy-match-expander legacy-match-expander? legacy-match-expander-proc)
|
||||
(make-struct-type-property/accessor 'prop:legacy-match-expander ))
|
||||
|
||||
(define make-match-expander
|
||||
(let ()
|
||||
(define-struct match-expander (match-xform legacy-xform macro-xform)
|
||||
#:property prop:set!-transformer (lambda (me stx)
|
||||
(define xf (match-expander-macro-xform me))
|
||||
(if (set!-transformer? xf)
|
||||
((set!-transformer-procedure xf) stx)
|
||||
(syntax-case stx (set!)
|
||||
[(set! . _)
|
||||
(raise-syntax-error #f "cannot mutate syntax identifier" stx)]
|
||||
[_ (xf stx)])))
|
||||
#:property prop:match-expander (struct-field-index match-xform)
|
||||
#:property prop:legacy-match-expander (struct-field-index legacy-xform))
|
||||
(values make-match-expander)))
|
||||
|
||||
(provide match-expander? legacy-match-expander?
|
||||
match-expander-proc legacy-match-expander-proc
|
||||
prop:match-expander prop:legacy-match-expander)
|
||||
|
|
|
|||
|
|
@ -525,6 +525,35 @@ For example, to extend the pattern matcher and destructure syntax lists,
|
|||
|
||||
}
|
||||
|
||||
@defthing[prop:match-expander struct-type-property?]{
|
||||
|
||||
A @tech{structure type property} to identify structure types that act
|
||||
as @tech{match expanders} like the ones created by
|
||||
@racket[define-match-expander].
|
||||
|
||||
The property value must be an exact non-negative integer or a
|
||||
procedure of one or two arguments. In the former case, the integer
|
||||
designates a field within the structure that should contain a
|
||||
procedure; the integer must be between @racket[0] (inclusive) and the
|
||||
number of non-automatic fields in the structure type (exclusive, not
|
||||
counting supertype fields), and the designated field must also be
|
||||
specified as immutable.
|
||||
|
||||
If the property value is a procedure of one argument, then the
|
||||
procedure serves as the transformer for match expansion. If the property value is a procedure of two
|
||||
arguments, then the first argument is the structure whose type has
|
||||
@racket[prop:match-expander] property, and the second argument is a
|
||||
syntax object as for a @tech{match expander}..
|
||||
|
||||
If the property value is a @tech{assignment transformer}, then the wrapped
|
||||
procedure is extracted with
|
||||
@racket[set!-transformer-procedure] before it is called.
|
||||
}
|
||||
|
||||
@defthing[prop:legacy-match-expander struct-type-property?]{
|
||||
Like @racket[prop:match-expander], but for the legacy match syntax.
|
||||
}
|
||||
|
||||
|
||||
@defparam[match-equality-test comp-proc (any/c any/c . -> . any)]{
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user