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

Fix templates of union schemas

This commit is contained in:
Tony Garnock-Jones 2021-06-03 22:42:01 +02:00
parent 7ce9166a5d
commit 507f137c25
2 changed files with 10 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
syndicate/pattern.rkt
View File

@ -37,7 +37,7 @@
(define-syntax (define-preserves-pattern stx)
(syntax-case stx ()
[(_ (ctor-stx field-stxs ...) pattern-stx bindings-stx)
[(_ top-type-name (ctor-stx field-stxs ...) pattern-stx bindings-stx)
#`(begin (begin-for-syntax
(register-preserves-pattern!
#'ctor-stx
@ -50,7 +50,7 @@
['template
(syntax-case s ()
[(_ field-stxs ...)
(syntax (#,(format-id #'ctor-stx "~a->preserves" (syntax-e #'ctor-stx))
(syntax (#,(format-id #'ctor-stx "~a->preserves" (syntax-e #'top-type-name))
(ctor-stx field-stxs ...)))])]
['bindings
(syntax-case s ()

13
syndicate/schema-compiler.rkt
View File

@ -70,14 +70,14 @@
(if (equal? s discard) `() `(',k ,s)))))))]
[other (error 'pat-pattern "Unimplemented: ~v" other)]))
(define (top-pat name p ty k-nonrecord)
(define (top-pat top-name name p ty k-nonrecord)
(let ((fields (match ty
[(ty-unit) '()]
[(ty-record fields) (map escape (map car fields))]
[_ #f])))
(if (not fields)
(k-nonrecord)
`(define-preserves-pattern (,name ,@fields)
`(define-preserves-pattern ,top-name (,name ,@fields)
(quasisyntax ,(pat-pattern p))
(append ,@(for/list [(f (in-list fields))]
`(analyse-pattern-bindings (syntax ,f))))))))
@ -87,12 +87,15 @@
`(begin ,@(for/list [(named-alt (in-list (list* p0 p1 pN)))
(alt-ty (in-list (map cadr (ty-union-variants (definition-ty def)))))]
(match-define (NamedAlternative variant-label-str pattern) named-alt)
(top-pat (format-symbol "~a-~a" name variant-label-str) pattern alt-ty
(lambda () `(begin)))))]
(define full-name (format-symbol "~a-~a" name variant-label-str))
(top-pat name full-name pattern alt-ty
(lambda () `(define-preserves-pattern ,name (,full-name value)
(analyse-pattern #'value)
(analyse-pattern-bindings (syntax value)))))))]
[(? Definition-and?)
`(begin)]
[(Definition-Pattern p)
(top-pat name p (definition-ty def) (lambda () `(begin)))]))
(top-pat name name p (definition-ty def) (lambda () `(begin)))]))
(define exprs
`((require (prefix-in :pat: ,ds-path))