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) (define-syntax (define-preserves-pattern stx)
(syntax-case 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 #`(begin (begin-for-syntax
(register-preserves-pattern! (register-preserves-pattern!
#'ctor-stx #'ctor-stx
@ -50,7 +50,7 @@
['template ['template
(syntax-case s () (syntax-case s ()
[(_ field-stxs ...) [(_ 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 ...)))])] (ctor-stx field-stxs ...)))])]
['bindings ['bindings
(syntax-case s () (syntax-case s ()

13
syndicate/schema-compiler.rkt
View File

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