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

Named arguments to analyse-pattern

This commit is contained in:
Tony Garnock-Jones 2022-12-15 11:42:06 +13:00
parent cfe2cc4af7
commit afb887e649
1 changed files with 8 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
syndicate/pattern.rkt
View File

@ -113,13 +113,12 @@
[(list* k v more) (append (f k v) (append-map-pairs f more))]))
(define (analyse-pattern stx
[check-destructuring (lambda (stx) stx)]
[wrap-literal (lambda (stx) 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 (analyse-pattern pat-stx check-destructuring wrap-literal)))
(append-map-pairs (lambda (key-stx pat-stx) (list key-stx (walk pat-stx)))
(syntax->list pieces-stx)))
(let walk ((stx stx))
(define (walk stx)
(define disarmed-stx (syntax-disarm stx orig-insp))
(syntax-case disarmed-stx ($ quasiquote unquote quote)
[expander
@ -181,7 +180,8 @@
(hash-or-hasheqv-id? #'hash-stx))
#`(dict* (hash-stx #,@(walk-hash #'(piece ...))))]
[other #`(literal->literal-pattern #,(wrap-literal #'other))])))
[other #`(literal->literal-pattern #,(wrap-literal #'other))]))
(walk stx))
(define (analyse-pattern-bindings stx)
(let walk ((stx stx))
@ -294,7 +294,9 @@
(syntax-case stx ()
[(_ pat-stx atomic-literal-transformer)
(analyse-pattern #'pat-stx
#:check-destructuring
(lambda (stx) (raise-syntax-error #f "Attempt to destructure known-atomic"))
#:wrap-literal
(lambda (stx) #`(atomic-literal-transformer #,stx)))]
[(_ pat-stx)
(analyse-pattern #'pat-stx)])))