instantiate-pattern
This commit is contained in:
parent
2124915de2
commit
639ceae231
|
@ -7,6 +7,7 @@
|
||||||
register-preserves-pattern!
|
register-preserves-pattern!
|
||||||
analyse-pattern
|
analyse-pattern
|
||||||
analyse-pattern-bindings
|
analyse-pattern-bindings
|
||||||
|
instantiate-pattern
|
||||||
analyse-match-pattern)
|
analyse-match-pattern)
|
||||||
define-preserves-pattern
|
define-preserves-pattern
|
||||||
:pattern
|
:pattern
|
||||||
|
@ -137,12 +138,13 @@
|
||||||
(define (transform-binding id-stx expanded-stx)
|
(define (transform-binding id-stx expanded-stx)
|
||||||
((syntax-parameter-value #'transform-pattern-binding) id-stx expanded-stx))
|
((syntax-parameter-value #'transform-pattern-binding) id-stx expanded-stx))
|
||||||
|
|
||||||
|
(define (walk-hash walk pieces-stx)
|
||||||
|
(append-map-pairs (lambda (key-stx pat-stx) (list key-stx (walk pat-stx)))
|
||||||
|
(syntax->list pieces-stx)))
|
||||||
|
|
||||||
(define (analyse-pattern stx
|
(define (analyse-pattern stx
|
||||||
#:check-destructuring [check-destructuring (lambda (stx) stx)]
|
#:check-destructuring [check-destructuring (lambda (stx) stx)]
|
||||||
#:wrap-literal [wrap-literal (lambda (stx) stx)])
|
#:wrap-literal [wrap-literal (lambda (stx) stx)])
|
||||||
(define (walk-hash pieces-stx)
|
|
||||||
(append-map-pairs (lambda (key-stx pat-stx) (list key-stx (walk pat-stx)))
|
|
||||||
(syntax->list pieces-stx)))
|
|
||||||
(define (walk stx)
|
(define (walk stx)
|
||||||
(define disarmed-stx (syntax-disarm stx orig-insp))
|
(define disarmed-stx (syntax-disarm stx orig-insp))
|
||||||
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
||||||
|
@ -174,7 +176,7 @@
|
||||||
|
|
||||||
[(hash-stx piece ...)
|
[(hash-stx piece ...)
|
||||||
(hash-or-hasheqv-id? #'hash-stx)
|
(hash-or-hasheqv-id? #'hash-stx)
|
||||||
(check-destructuring #`(dict (hash #,@(walk-hash #'(piece ...)))))]
|
(check-destructuring #`(dict (hash #,@(walk-hash walk #'(piece ...)))))]
|
||||||
|
|
||||||
[id
|
[id
|
||||||
(dollar-id? #'id)
|
(dollar-id? #'id)
|
||||||
|
@ -200,7 +202,7 @@
|
||||||
[(c (hash-stx piece ...))
|
[(c (hash-stx piece ...))
|
||||||
(and (id=? #'dict #'c)
|
(and (id=? #'dict #'c)
|
||||||
(hash-or-hasheqv-id? #'hash-stx))
|
(hash-or-hasheqv-id? #'hash-stx))
|
||||||
#`(dict* (hash-stx #,@(walk-hash #'(piece ...))))]
|
#`(dict* (hash-stx #,@(walk-hash walk #'(piece ...))))]
|
||||||
|
|
||||||
[other #`(literal->literal-pattern #,(wrap-literal #'other))]))
|
[other #`(literal->literal-pattern #,(wrap-literal #'other))]))
|
||||||
(walk stx))
|
(walk stx))
|
||||||
|
@ -264,6 +266,41 @@
|
||||||
|
|
||||||
[other '()])))
|
[other '()])))
|
||||||
|
|
||||||
|
(define (instantiate-pattern stx lookup)
|
||||||
|
(let walk ((stx stx))
|
||||||
|
(define disarmed-stx (syntax-disarm stx orig-insp))
|
||||||
|
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
||||||
|
[expander
|
||||||
|
(pattern-expander-form? #'expander)
|
||||||
|
(pattern-expander-transform disarmed-stx
|
||||||
|
(lambda (result) (walk (syntax-rearm result stx))))]
|
||||||
|
|
||||||
|
;; Extremely limited support for quasiquoting and quoting
|
||||||
|
[(quasiquote (unquote p)) (walk #'p)]
|
||||||
|
[(quasiquote (p ...)) (walk #'(list (quasiquote p) ...))]
|
||||||
|
[(quasiquote _p) '()]
|
||||||
|
[(quote _p) '()]
|
||||||
|
|
||||||
|
[(hash-stx piece ...)
|
||||||
|
(hash-or-hasheqv-id? #'hash-stx)
|
||||||
|
(quasisyntax/loc stx (hash-stx #,@(walk-hash walk #'(piece ...))))]
|
||||||
|
|
||||||
|
[id
|
||||||
|
(dollar-id? #'id)
|
||||||
|
(lookup (undollar #'id) #f)]
|
||||||
|
|
||||||
|
[($ id p)
|
||||||
|
(lookup #'id (lambda () (walk #'p)))]
|
||||||
|
|
||||||
|
[id
|
||||||
|
(discard-id? #'id)
|
||||||
|
(raise-syntax-error 'instantiate-pattern "Cannot instantiate discard patterns" stx)]
|
||||||
|
|
||||||
|
[(f args ...)
|
||||||
|
(quasisyntax/loc stx (f #,@(map walk (syntax->list #'(args ...)))))]
|
||||||
|
|
||||||
|
[other #'other])))
|
||||||
|
|
||||||
(define (analyse-match-pattern stx)
|
(define (analyse-match-pattern stx)
|
||||||
(let walk ((stx stx))
|
(let walk ((stx stx))
|
||||||
(define disarmed-stx (syntax-disarm stx orig-insp))
|
(define disarmed-stx (syntax-disarm stx orig-insp))
|
||||||
|
|
Loading…
Reference in New Issue