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

Fix embedded (un)parsing to rely on the reader

This commit is contained in:
Tony Garnock-Jones 2021-06-08 09:27:03 +02:00
parent a4d61017d8
commit 30bcc1a50b
4 changed files with 65 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -88,10 +88,10 @@
(define (embedded-defs schema) (define (embedded-defs schema)
(match (Schema-embeddedType schema) (match (Schema-embeddedType schema)
[(EmbeddedTypeName-false) `((define :parse-embedded values) [(EmbeddedTypeName-false) `((define :decode-embedded values)
(define :embedded->preserves values))] (define :encode-embedded values))]
[(EmbeddedTypeName-Ref r) `((define :parse-embedded ,(Ref-parser-name r)) [(EmbeddedTypeName-Ref r) `((define :decode-embedded ,(Ref-parser!-name r))
(define :embedded->preserves ,(Ref-unparser-name r)))])) (define :encode-embedded ,(Ref-unparser-name r)))]))
(define (struct-defs schema) (define (struct-defs schema)
(fold-Schema-definitions (fold-Schema-definitions
@ -133,9 +133,9 @@
(schema-check-problems! schema #:name name) (schema-check-problems! schema #:name name)
(define options (schema-compiler-options name lookup-module-path translation-paths)) (define options (schema-compiler-options name lookup-module-path translation-paths))
`(module ,name racket/base `(module ,name racket/base
(provide (except-out (all-defined-out) :parse-embedded :embedded->preserves) (provide (except-out (all-defined-out) :decode-embedded :encode-embedded)
(rename-out [:parse-embedded ,(format-symbol ":parse-embedded:~a" name)] (rename-out [:decode-embedded ,(format-symbol "decode-embedded:~a" name)]
[:embedded->preserves ,(format-symbol ":embedded->preserves:~a" name)])) [:encode-embedded ,(format-symbol "encode-embedded:~a" name)]))
,@(module-imports name schema lookup-module-path translation-paths) ,@(module-imports name schema lookup-module-path translation-paths)
,@(embedded-defs schema) ,@(embedded-defs schema)
(require preserves) (require preserves)

100
implementations/racket/preserves/preserves-schema/gen/schema.rkt
View File

@ -1,10 +1,10 @@
(module gen-schema racket/base (module gen-schema racket/base
(provide (except-out (all-defined-out) :parse-embedded :embedded->preserves) (provide (except-out (all-defined-out) :decode-embedded :encode-embedded)
(rename-out (rename-out
(:parse-embedded :parse-embedded:gen-schema) (:decode-embedded decode-embedded:gen-schema)
(:embedded->preserves :embedded->preserves:gen-schema))) (:encode-embedded encode-embedded:gen-schema)))
(define :parse-embedded values) (define :decode-embedded values)
(define :embedded->preserves values) (define :encode-embedded values)
(require preserves) (require preserves)
(require preserves-schema/support) (require preserves-schema/support)
(require racket/match) (require racket/match)
@ -99,8 +99,8 @@
((and dest ((and dest
(record (record
'bundle 'bundle
(list (app parse-Modules (and $modules (not (== eof))))))) (list (app parse-Modules (and ?modules (not (== eof)))))))
(Bundle $modules)) (Bundle ?modules))
(_ eof))) (_ eof)))
(define parse-Bundle! (parse-success-or-error 'parse-Bundle parse-Bundle))) (define parse-Bundle! (parse-success-or-error 'parse-Bundle parse-Bundle)))
(begin (begin
@ -111,30 +111,30 @@
(record (record
'rec 'rec
(list (list
(app parse-NamedPattern (and $label (not (== eof)))) (app parse-NamedPattern (and ?label (not (== eof))))
(app parse-NamedPattern (and $fields (not (== eof))))))) (app parse-NamedPattern (and ?fields (not (== eof)))))))
(CompoundPattern-rec $label $fields)) (CompoundPattern-rec ?label ?fields))
((and dest ((and dest
(record (record
'tuple 'tuple
(list (list
(list (list
(app parse-NamedPattern (and $patterns (not (== eof)))) (app parse-NamedPattern (and ?patterns (not (== eof))))
...)))) ...))))
(CompoundPattern-tuple $patterns)) (CompoundPattern-tuple ?patterns))
((and dest ((and dest
(record (record
'tuple* 'tuple*
(list (list
(list (app parse-NamedPattern (and $fixed (not (== eof)))) ...) (list (app parse-NamedPattern (and ?fixed (not (== eof)))) ...)
(app parse-NamedSimplePattern (and $variable (not (== eof))))))) (app parse-NamedSimplePattern (and ?variable (not (== eof)))))))
(CompoundPattern-tuple* $fixed $variable)) (CompoundPattern-tuple* ?fixed ?variable))
((and dest ((and dest
(record (record
'dict 'dict
(list (list
(app parse-DictionaryEntries (and $entries (not (== eof))))))) (app parse-DictionaryEntries (and ?entries (not (== eof)))))))
(CompoundPattern-dict $entries)) (CompoundPattern-dict ?entries))
(_ eof))) (_ eof)))
(define parse-CompoundPattern! (define parse-CompoundPattern!
(parse-success-or-error 'parse-CompoundPattern parse-CompoundPattern))) (parse-success-or-error 'parse-CompoundPattern parse-CompoundPattern)))
@ -147,23 +147,23 @@
'or 'or
(list (list
(list* (list*
(app parse-NamedAlternative (and $pattern0 (not (== eof)))) (app parse-NamedAlternative (and ?pattern0 (not (== eof))))
(app parse-NamedAlternative (and $pattern1 (not (== eof)))) (app parse-NamedAlternative (and ?pattern1 (not (== eof))))
(list (list
(app parse-NamedAlternative (and $patternN (not (== eof)))) (app parse-NamedAlternative (and ?patternN (not (== eof))))
...))))) ...)))))
(Definition-or $pattern0 $pattern1 $patternN)) (Definition-or ?pattern0 ?pattern1 ?patternN))
((and dest ((and dest
(record (record
'and 'and
(list (list
(list* (list*
(app parse-NamedPattern (and $pattern0 (not (== eof)))) (app parse-NamedPattern (and ?pattern0 (not (== eof))))
(app parse-NamedPattern (and $pattern1 (not (== eof)))) (app parse-NamedPattern (and ?pattern1 (not (== eof))))
(list (list
(app parse-NamedPattern (and $patternN (not (== eof)))) (app parse-NamedPattern (and ?patternN (not (== eof))))
...))))) ...)))))
(Definition-and $pattern0 $pattern1 $patternN)) (Definition-and ?pattern0 ?pattern1 ?patternN))
((app parse-Pattern (and dest (not (== eof)))) ((app parse-Pattern (and dest (not (== eof))))
(Definition-Pattern dest)) (Definition-Pattern dest))
(_ eof))) (_ eof)))
@ -240,9 +240,9 @@
input input
((and dest ((and dest
(list (list
(and $variantLabel (? string?)) (and ?variantLabel (? string?))
(app parse-Pattern (and $pattern (not (== eof)))))) (app parse-Pattern (and ?pattern (not (== eof))))))
(NamedAlternative $variantLabel $pattern)) (NamedAlternative ?variantLabel ?pattern))
(_ eof))) (_ eof)))
(define parse-NamedAlternative! (define parse-NamedAlternative!
(parse-success-or-error 'parse-NamedAlternative parse-NamedAlternative))) (parse-success-or-error 'parse-NamedAlternative parse-NamedAlternative)))
@ -278,9 +278,9 @@
(record (record
'named 'named
(list (list
(and $name (? symbol?)) (and ?name (? symbol?))
(app parse-SimplePattern (and $pattern (not (== eof))))))) (app parse-SimplePattern (and ?pattern (not (== eof)))))))
(NamedSimplePattern_ $name $pattern)) (NamedSimplePattern_ ?name ?pattern))
(_ eof))) (_ eof)))
(define parse-NamedSimplePattern_! (define parse-NamedSimplePattern_!
(parse-success-or-error (parse-success-or-error
@ -305,9 +305,9 @@
(record (record
'ref 'ref
(list (list
(app parse-ModulePath (and $module (not (== eof)))) (app parse-ModulePath (and ?module (not (== eof))))
(and $name (? symbol?))))) (and ?name (? symbol?)))))
(Ref $module $name)) (Ref ?module ?name))
(_ eof))) (_ eof)))
(define parse-Ref! (parse-success-or-error 'parse-Ref parse-Ref))) (define parse-Ref! (parse-success-or-error 'parse-Ref parse-Ref)))
(begin (begin
@ -320,15 +320,15 @@
(list (list
(hash-table (hash-table
('definitions ('definitions
(app parse-Definitions (and $definitions (not (== eof))))) (app parse-Definitions (and ?definitions (not (== eof)))))
('embeddedType ('embeddedType
(app (app
parse-EmbeddedTypeName parse-EmbeddedTypeName
(and $embeddedType (not (== eof))))) (and ?embeddedType (not (== eof)))))
('version (app parse-Version (and $version (not (== eof))))) ('version (app parse-Version (and ?version (not (== eof)))))
(_ _) (_ _)
...)))) ...))))
(Schema $definitions $embeddedType $version)) (Schema ?definitions ?embeddedType ?version))
(_ eof))) (_ eof)))
(define parse-Schema! (parse-success-or-error 'parse-Schema parse-Schema))) (define parse-Schema! (parse-success-or-error 'parse-Schema parse-Schema)))
(begin (begin
@ -339,32 +339,32 @@
((and dest ((and dest
(record (record
'atom 'atom
(list (app parse-AtomKind (and $atomKind (not (== eof))))))) (list (app parse-AtomKind (and ?atomKind (not (== eof)))))))
(SimplePattern-atom $atomKind)) (SimplePattern-atom ?atomKind))
((and dest ((and dest
(record (record
'embedded 'embedded
(list (list
(app parse-SimplePattern (and $interface (not (== eof))))))) (app parse-SimplePattern (and ?interface (not (== eof)))))))
(SimplePattern-embedded $interface)) (SimplePattern-embedded ?interface))
((and dest (record 'lit (list $value))) (SimplePattern-lit $value)) ((and dest (record 'lit (list ?value))) (SimplePattern-lit ?value))
((and dest ((and dest
(record (record
'seqof 'seqof
(list (app parse-SimplePattern (and $pattern (not (== eof))))))) (list (app parse-SimplePattern (and ?pattern (not (== eof)))))))
(SimplePattern-seqof $pattern)) (SimplePattern-seqof ?pattern))
((and dest ((and dest
(record (record
'setof 'setof
(list (app parse-SimplePattern (and $pattern (not (== eof))))))) (list (app parse-SimplePattern (and ?pattern (not (== eof)))))))
(SimplePattern-setof $pattern)) (SimplePattern-setof ?pattern))
((and dest ((and dest
(record (record
'dictof 'dictof
(list (list
(app parse-SimplePattern (and $key (not (== eof)))) (app parse-SimplePattern (and ?key (not (== eof))))
(app parse-SimplePattern (and $value (not (== eof))))))) (app parse-SimplePattern (and ?value (not (== eof)))))))
(SimplePattern-dictof $key $value)) (SimplePattern-dictof ?key ?value))
((app parse-Ref (and dest (not (== eof)))) (SimplePattern-Ref dest)) ((app parse-Ref (and dest (not (== eof)))) (SimplePattern-Ref dest))
(_ eof))) (_ eof)))
(define parse-SimplePattern! (define parse-SimplePattern!

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

@ -1,7 +1,8 @@
#lang racket/base #lang racket/base
(provide definition-parsers (provide definition-parsers
Ref-parser-name) Ref-parser-name
Ref-parser!-name)
(require preserves) (require preserves)
(require racket/match) (require racket/match)
@ -66,7 +67,7 @@
[(AtomKind-ByteString) 'bytes?] [(AtomKind-ByteString) 'bytes?]
[(AtomKind-Symbol) 'symbol?])))] [(AtomKind-Symbol) 'symbol?])))]
[(SimplePattern-embedded _interface) [(SimplePattern-embedded _interface)
`(embedded (app :parse-embedded ,(maybe-dest dest-pat-stx `(not (== eof)))))] `(embedded ,(maybe-dest dest-pat-stx `_))]
[(SimplePattern-lit v) (maybe-dest dest-pat-stx (literal->pattern v))] [(SimplePattern-lit v) (maybe-dest dest-pat-stx (literal->pattern v))]
[(SimplePattern-seqof variable-pat) [(SimplePattern-seqof variable-pat)
`(list ,(pattern->match-pattern variable-pat dest-pat-stx) ...)] `(list ,(pattern->match-pattern variable-pat dest-pat-stx) ...)]
@ -111,6 +112,10 @@
(match-define (Ref module-path name) r) (match-define (Ref module-path name) r)
(format-symbol "~aparse-~a" (module-path-prefix module-path) name)) (format-symbol "~aparse-~a" (module-path-prefix module-path) name))
(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

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

@ -48,7 +48,7 @@
[(NamedSimplePattern_ n p) (pattern->unparser p (escape n))] [(NamedSimplePattern_ n p) (pattern->unparser p (escape n))]
[(SimplePattern-any) src-stx] [(SimplePattern-any) src-stx]
[(SimplePattern-atom _) src-stx] [(SimplePattern-atom _) src-stx]
[(SimplePattern-embedded _interface) `(embedded (:embedded->preserves ,src-stx))] [(SimplePattern-embedded _interface) `(embedded ,src-stx)]
[(SimplePattern-lit v) `',v] [(SimplePattern-lit v) `',v]
[(SimplePattern-seqof variable-pat) [(SimplePattern-seqof variable-pat)
`(for/list [(item (in-list ,src-stx))] ,(pattern->unparser variable-pat 'item))] `(for/list [(item (in-list ,src-stx))] ,(pattern->unparser variable-pat 'item))]