From ab12c6535fbad5fd7c0a860924e159842517e0eb Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 27 May 2021 09:53:55 +0200 Subject: [PATCH] Simpler embedded parsing/unparsing --- .../racket/preserves/preserves-schema/compiler.rkt | 9 +++------ .../racket/preserves/preserves-schema/parser.rkt | 11 +++++++---- .../racket/preserves/preserves-schema/unparser.rkt | 10 +++++++--- 3 files changed, 17 insertions(+), 13 deletions(-) diff --git a/implementations/racket/preserves/preserves-schema/compiler.rkt b/implementations/racket/preserves/preserves-schema/compiler.rkt index 53c75af..0ff0c3a 100644 --- a/implementations/racket/preserves/preserves-schema/compiler.rkt +++ b/implementations/racket/preserves/preserves-schema/compiler.rkt @@ -73,12 +73,9 @@ (match (Schema-embeddedType schema) [(EmbeddedTypeName-false) `((define :parse-embedded values) (define :embedded->preserves values))] - [(EmbeddedTypeName-Ref r) `((define (:parse-embedded input) - (match input - [,(pattern->match-pattern (SimplePattern-Ref r) 'output) output] - [_ eof])) - (define (:embedded->preserves input) - ,(pattern->unparser (SimplePattern-Ref r) 'input)))])) + [(EmbeddedTypeName-Ref r) `((define :parse-embedded ,(Ref-parser-name r)) + (define :embedded->preserves ,(Ref-unparser-name r)))])) + (define (struct-defs schema) (fold-Schema-definitions (lambda (name def acc) diff --git a/implementations/racket/preserves/preserves-schema/parser.rkt b/implementations/racket/preserves/preserves-schema/parser.rkt index f0f839d..7a09233 100644 --- a/implementations/racket/preserves/preserves-schema/parser.rkt +++ b/implementations/racket/preserves/preserves-schema/parser.rkt @@ -1,7 +1,7 @@ #lang racket/base (provide definition-parsers - pattern->match-pattern) + Ref-parser-name) (require preserves) (require racket/match) @@ -83,9 +83,8 @@ (cons key value) make-immutable-hash ,dest-pat-stx)] - [(SimplePattern-Ref (Ref module-path name)) - `(app ,(format-symbol "~aparse-~a" (module-path-prefix module-path) name) - ,(maybe-dest dest-pat-stx `(not (== eof))))] + [(SimplePattern-Ref r) + `(app ,(Ref-parser-name r) ,(maybe-dest dest-pat-stx `(not (== eof))))] [(CompoundPattern-rec label-pat fields-pat) (maybe-dest dest-pat-stx `(record ,(pattern->match-pattern label-pat '_) ,(pattern->match-pattern fields-pat '_)))] @@ -106,6 +105,10 @@ (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) (if (symbol? v) `',v diff --git a/implementations/racket/preserves/preserves-schema/unparser.rkt b/implementations/racket/preserves/preserves-schema/unparser.rkt index e816f3c..87f4b81 100644 --- a/implementations/racket/preserves/preserves-schema/unparser.rkt +++ b/implementations/racket/preserves/preserves-schema/unparser.rkt @@ -1,7 +1,7 @@ #lang racket/base (provide definition-unparser - pattern->unparser) + Ref-unparser-name) (require preserves) (require racket/match) @@ -58,8 +58,8 @@ `(for/hash [((key value) (in-dict ,src-stx))] (values ,(pattern->unparser key-pat 'key) ,(pattern->unparser value-pat 'value)))] - [(SimplePattern-Ref (Ref module-path name)) - `(,(format-symbol "~a~a->preserves" (module-path-prefix module-path) name) ,src-stx)] + [(SimplePattern-Ref r) + `(,(Ref-unparser-name r) ,src-stx)] [(CompoundPattern-rec label-pat fields-pat) `(record ,(pattern->unparser label-pat src-stx) ,(pattern->unparser fields-pat src-stx))] [(CompoundPattern-tuple named-pats) @@ -72,3 +72,7 @@ (list `',(car entry) (pattern->unparser (cdr entry) src-stx))) (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))