syndicate-lang
/
preserves
mirror of https://gitlab.com/preserves/preserves.git
1
0
Fork 1
Code Releases Activity

Add struct ty-field for better structure in ty-records

This commit is contained in:
Tony Garnock-Jones 2021-06-08 09:56:04 +02:00
parent 30bcc1a50b
commit 0bcb4e64ec
4 changed files with 9 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
implementations/racket/preserves/preserves-schema/compiler.rkt
View File

@ -106,7 +106,7 @@
(match-define (list variant-name variant-ty) variant) (match-define (list variant-name variant-ty) variant)
(match variant-ty (match variant-ty
[(ty-record fields) [(ty-record fields)
(cons (struct-stx (list name variant-name) (map car fields)) acc)] (cons (struct-stx (list name variant-name) (map ty-field-name fields)) acc)]
[(ty-unit) [(ty-unit)
(cons (struct-stx (list name variant-name) '()) acc)] (cons (struct-stx (list name variant-name) '()) acc)]
[_ [_
@ -114,7 +114,7 @@
[(ty-unit) [(ty-unit)
(cons (struct-stx (list name) '()) acc)] (cons (struct-stx (list name) '()) acc)]
[(ty-record fields) [(ty-record fields)
(cons (struct-stx (list name) (map car fields)) acc)] (cons (struct-stx (list name) (map ty-field-name fields)) acc)]
[_ [_
acc])) acc]))
'() '()

2
implementations/racket/preserves/preserves-schema/parser.rkt
View File

@ -41,7 +41,7 @@
(define (construct name wrap? ty) (define (construct name wrap? ty)
(match ty (match ty
[(ty-record fields) `(,name ,@(map escape (map car fields)))] [(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
[(ty-unit) `(,name)] [(ty-unit) `(,name)]
[_ (if wrap? `(,name dest) 'dest)])) [_ (if wrap? `(,name dest) 'dest)]))

6
implementations/racket/preserves/preserves-schema/type.rkt
View File

@ -8,6 +8,8 @@
(struct-out ty-set) (struct-out ty-set)
(struct-out ty-dictionary) (struct-out ty-dictionary)
(struct-out ty-field)
definition-ty definition-ty
unwrap unwrap
namelike namelike
@ -30,6 +32,8 @@
(struct ty-set (type) #:transparent) (struct ty-set (type) #:transparent)
(struct ty-dictionary (key-type value-type) #:transparent) (struct ty-dictionary (key-type value-type) #:transparent)
(struct ty-field (name type pattern) #:transparent)
(define (definition-ty d) (define (definition-ty d)
(match d (match d
[(Definition-or p0 p1 pN) [(Definition-or p0 p1 pN)
@ -63,7 +67,7 @@
[(NamedSimplePattern_ n p) [(NamedSimplePattern_ n p)
(match (pattern-ty p) (match (pattern-ty p)
[(ty-unit) acc] [(ty-unit) acc]
[ty (cons (list n ty) acc)])] [ty (cons (ty-field n ty p) acc)])]
[(? SimplePattern?) acc] [(? SimplePattern?) acc]
[(CompoundPattern-rec label-named-pat fields-named-pat) [(CompoundPattern-rec label-named-pat fields-named-pat)
(gather-fields label-named-pat (gather-fields fields-named-pat acc))] (gather-fields label-named-pat (gather-fields fields-named-pat acc))]

2
implementations/racket/preserves/preserves-schema/unparser.rkt
View File

@ -39,7 +39,7 @@
(define (deconstruct name wrap? ty) (define (deconstruct name wrap? ty)
(match ty (match ty
[(ty-record fields) `(,name ,@(map escape (map car fields)))] [(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
[(ty-unit) `(,name)] [(ty-unit) `(,name)]
[_ (if wrap? `(,name src) 'src)])) [_ (if wrap? `(,name src) 'src)]))