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

record patterns

This commit is contained in:
Tony Garnock-Jones 2024-05-17 13:01:09 +02:00
parent c538c577c3
commit 6aa1250d32
1 changed files with 19 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
syndicate/pattern.rkt
View File

@ -27,6 +27,7 @@
(all-from-out "schemas/dataspacePatterns.rkt"))
(require (for-syntax preserves/record))
(require (for-syntax racket/base))
(require (for-syntax racket/match))
(require (for-syntax racket/list))
@ -114,6 +115,7 @@
(define (discard-id? stx) (id=? #'_ stx))
(define (list-id? stx) (id=? #'list stx))
(define (record-id? stx) (id=? #'record stx))
(define (hash-or-hasheqv-id? stx) (or (id=? #'hash stx) (id=? #'hasheqv stx)))
(define (constructor-registered? stx)
@ -172,6 +174,10 @@
(let ((label (struct-label/arity-check #'ctor (length (syntax->list #'(piece ...))))))
(check-destructuring #`(rec '#,label (list #,@(map walk (syntax->list #'(piece ...)))))))]
[(record-stx label (list-stx piece ...))
(and (record-id? #'record-stx) (list-id? #'list-stx))
(check-destructuring #`(rec label (list #,@(map walk (syntax->list #'(piece ...))))))]
[(list-stx piece ...)
(list-id? #'list-stx)
(check-destructuring #`(arr (list #,@(map walk (syntax->list #'(piece ...))))))]
@ -232,6 +238,10 @@
(struct-info? (id-value #'ctor))
(append-map walk (syntax->list #'(piece ...)))]
[(record-stx _label (list-stx piece ...))
(and (record-id? #'record-stx) (list-id? #'list-stx))
(append-map walk (syntax->list #'(piece ...)))]
[(list-stx piece ...)
(list-id? #'list-stx)
(append-map walk (syntax->list #'(piece ...)))]
@ -287,6 +297,11 @@
(hash-or-hasheqv-id? #'hash-stx)
(quasisyntax/loc stx (hash-stx #,@(walk-hash walk #'(piece ...))))]
[(record-stx label (list-stx piece ...))
(and (record-id? #'record-stx) (list-id? #'list-stx))
(quasisyntax/loc stx
(record-stx label (list-stx #,@(map walk (syntax->list #'(piece ...))))))]
[id
(dollar-id? #'id)
(lookup (undollar #'id) #f)]
@ -328,6 +343,10 @@
(struct-info? (id-value #'ctor))
#`(ctor (:parse piece) ...)]
[(record-stx label fields)
(record-id? #'record-stx)
#`(record-stx label (:parse fields))]
[(list-stx piece ...)
(list-id? #'list-stx)
#`(list-stx (:parse piece) ...)]