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

Hash-table patterns

This commit is contained in:
Tony Garnock-Jones 2021-06-03 22:42:42 +02:00
parent 507f137c25
commit 12df86ee74
1 changed files with 26 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
syndicate/pattern.rkt
View File

@ -84,6 +84,11 @@
(and (identifier? stx)
(free-identifier=? #'list stx)))
(define (hash-or-hasheqv-id? stx)
(and (identifier? stx)
(or (free-identifier=? #'hash stx)
(free-identifier=? #'hasheqv stx))))
(define (constructor-registered? stx)
(free-id-table-ref preserves-pattern-registry stx #f))
@ -106,6 +111,12 @@
(values (syntax-e ctor-stx)
expected-count))
(define (append-map-pairs f xs)
(match xs
['() '()]
[(list _) (raise-syntax-error #f "Odd number of elements in hash-like pattern")]
[(list* k v more) (append (f k v) (append-map-pairs f more))]))
(define (analyse-pattern stx)
(define disarmed-stx (syntax-disarm stx orig-insp))
(syntax-case disarmed-stx ($ quasiquote unquote quote)
@ -144,6 +155,12 @@
(piece (in-list (syntax->list #'(piece ...))))]
(member-entry n piece))))))]
[(hash-stx piece ...)
(hash-or-hasheqv-id? #'hash-stx)
#`(Pattern-DCompound
(DCompound-dict (CDict)
(hash #,@(append-map-pairs member-entry (syntax->list #'(piece ...))))))]
[id
(dollar-id? #'id)
#`(Pattern-DBind (DBind '#,(undollar #'id) (Pattern-DDiscard (DDiscard))))]
@ -185,6 +202,10 @@
(list-id? #'list-stx)
(append-map analyse-pattern-bindings (syntax->list #'(piece ...)))]
[(hash-stx piece ...)
(hash-or-hasheqv-id? #'hash-stx)
(append-map-pairs (lambda (_k v) (analyse-pattern-bindings v)) (syntax->list #'(piece ...)))]
[id
(dollar-id? #'id)
(list (undollar #'id))]
@ -219,6 +240,11 @@
(list-id? #'list-stx)
#`(list-stx #,@(map analyse-template (syntax->list #'(piece ...))))]
[(hash-stx piece ...)
(hash-or-hasheqv-id? #'hash-stx)
#`(hash-stx #,@(append-map-pairs (lambda (k v) (list k (analyse-template v)))
(syntax->list #'(piece ...))))]
[other #'other])))
(define-syntax (:pattern stx)