syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

instantiate-pattern

This commit is contained in:
Tony Garnock-Jones 2023-01-02 11:20:00 +01:00
parent 2124915de2
commit 639ceae231
1 changed files with 42 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
syndicate/pattern.rkt
View File

@ -7,6 +7,7 @@
register-preserves-pattern!
analyse-pattern
analyse-pattern-bindings
instantiate-pattern
analyse-match-pattern)
define-preserves-pattern
:pattern
@ -137,12 +138,13 @@
(define (transform-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
#:check-destructuring [check-destructuring (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 disarmed-stx (syntax-disarm stx orig-insp))
(syntax-case disarmed-stx ($ quasiquote unquote quote)
@ -174,7 +176,7 @@
[(hash-stx piece ...)
(hash-or-hasheqv-id? #'hash-stx)
(check-destructuring #`(dict (hash #,@(walk-hash #'(piece ...)))))]
(check-destructuring #`(dict (hash #,@(walk-hash walk #'(piece ...)))))]
[id
(dollar-id? #'id)
@ -200,7 +202,7 @@
[(c (hash-stx piece ...))
(and (id=? #'dict #'c)
(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))]))
(walk stx))
@ -264,6 +266,41 @@
[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)
(let walk ((stx stx))
(define disarmed-stx (syntax-disarm stx orig-insp))