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

Simpler embedded parsing/unparsing

This commit is contained in:
Tony Garnock-Jones 2021-05-27 09:53:55 +02:00
parent 534018e3a4
commit ab12c6535f
3 changed files with 17 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -73,12 +73,9 @@
(match (Schema-embeddedType schema) (match (Schema-embeddedType schema)
[(EmbeddedTypeName-false) `((define :parse-embedded values) [(EmbeddedTypeName-false) `((define :parse-embedded values)
(define :embedded->preserves values))] (define :embedded->preserves values))]
[(EmbeddedTypeName-Ref r) `((define (:parse-embedded input) [(EmbeddedTypeName-Ref r) `((define :parse-embedded ,(Ref-parser-name r))
(match input (define :embedded->preserves ,(Ref-unparser-name r)))]))
[,(pattern->match-pattern (SimplePattern-Ref r) 'output) output]
[_ eof]))
(define (:embedded->preserves input)
,(pattern->unparser (SimplePattern-Ref r) 'input)))]))
(define (struct-defs schema) (define (struct-defs schema)
(fold-Schema-definitions (fold-Schema-definitions
(lambda (name def acc) (lambda (name def acc)

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

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(provide definition-parsers (provide definition-parsers
pattern->match-pattern) Ref-parser-name)
(require preserves) (require preserves)
(require racket/match) (require racket/match)
@ -83,9 +83,8 @@
(cons key value) (cons key value)
make-immutable-hash make-immutable-hash
,dest-pat-stx)] ,dest-pat-stx)]
[(SimplePattern-Ref (Ref module-path name)) [(SimplePattern-Ref r)
`(app ,(format-symbol "~aparse-~a" (module-path-prefix module-path) name) `(app ,(Ref-parser-name r) ,(maybe-dest dest-pat-stx `(not (== eof))))]
,(maybe-dest dest-pat-stx `(not (== eof))))]
[(CompoundPattern-rec label-pat fields-pat) [(CompoundPattern-rec label-pat fields-pat)
(maybe-dest dest-pat-stx `(record ,(pattern->match-pattern label-pat '_) (maybe-dest dest-pat-stx `(record ,(pattern->match-pattern label-pat '_)
,(pattern->match-pattern fields-pat '_)))] ,(pattern->match-pattern fields-pat '_)))]
@ -106,6 +105,10 @@
(sorted-dict-entries entries)) (sorted-dict-entries entries))
(_ _) ...))])) (_ _) ...))]))
(define (Ref-parser-name r)
(match-define (Ref module-path name) r)
(format-symbol "~aparse-~a" (module-path-prefix module-path) name))
(define (literal->pattern v) (define (literal->pattern v)
(if (symbol? v) (if (symbol? v)
`',v `',v

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

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(provide definition-unparser (provide definition-unparser
pattern->unparser) Ref-unparser-name)
(require preserves) (require preserves)
(require racket/match) (require racket/match)
@ -58,8 +58,8 @@
`(for/hash [((key value) (in-dict ,src-stx))] `(for/hash [((key value) (in-dict ,src-stx))]
(values ,(pattern->unparser key-pat 'key) (values ,(pattern->unparser key-pat 'key)
,(pattern->unparser value-pat 'value)))] ,(pattern->unparser value-pat 'value)))]
[(SimplePattern-Ref (Ref module-path name)) [(SimplePattern-Ref r)
`(,(format-symbol "~a~a->preserves" (module-path-prefix module-path) name) ,src-stx)] `(,(Ref-unparser-name r) ,src-stx)]
[(CompoundPattern-rec label-pat fields-pat) [(CompoundPattern-rec label-pat fields-pat)
`(record ,(pattern->unparser label-pat src-stx) ,(pattern->unparser fields-pat src-stx))] `(record ,(pattern->unparser label-pat src-stx) ,(pattern->unparser fields-pat src-stx))]
[(CompoundPattern-tuple named-pats) [(CompoundPattern-tuple named-pats)
@ -72,3 +72,7 @@
(list `',(car entry) (list `',(car entry)
(pattern->unparser (cdr entry) src-stx))) (pattern->unparser (cdr entry) src-stx)))
(sorted-dict-entries entries)))])) (sorted-dict-entries entries)))]))
(define (Ref-unparser-name r)
(match-define (Ref module-path name) r)
(format-symbol "~a~a->preserves" (module-path-prefix module-path) name))