Fix embedded (un)parsing to rely on the reader
This commit is contained in:
parent
a4d61017d8
commit
30bcc1a50b
|
|
@ -88,10 +88,10 @@
|
|||
|
||||
(define (embedded-defs schema)
|
||||
(match (Schema-embeddedType schema)
|
||||
[(EmbeddedTypeName-false) `((define :parse-embedded values)
|
||||
(define :embedded->preserves values))]
|
||||
[(EmbeddedTypeName-Ref r) `((define :parse-embedded ,(Ref-parser-name r))
|
||||
(define :embedded->preserves ,(Ref-unparser-name r)))]))
|
||||
[(EmbeddedTypeName-false) `((define :decode-embedded values)
|
||||
(define :encode-embedded values))]
|
||||
[(EmbeddedTypeName-Ref r) `((define :decode-embedded ,(Ref-parser!-name r))
|
||||
(define :encode-embedded ,(Ref-unparser-name r)))]))
|
||||
|
||||
(define (struct-defs schema)
|
||||
(fold-Schema-definitions
|
||||
|
|
@ -133,9 +133,9 @@
|
|||
(schema-check-problems! schema #:name name)
|
||||
(define options (schema-compiler-options name lookup-module-path translation-paths))
|
||||
`(module ,name racket/base
|
||||
(provide (except-out (all-defined-out) :parse-embedded :embedded->preserves)
|
||||
(rename-out [:parse-embedded ,(format-symbol ":parse-embedded:~a" name)]
|
||||
[:embedded->preserves ,(format-symbol ":embedded->preserves:~a" name)]))
|
||||
(provide (except-out (all-defined-out) :decode-embedded :encode-embedded)
|
||||
(rename-out [:decode-embedded ,(format-symbol "decode-embedded:~a" name)]
|
||||
[:encode-embedded ,(format-symbol "encode-embedded:~a" name)]))
|
||||
,@(module-imports name schema lookup-module-path translation-paths)
|
||||
,@(embedded-defs schema)
|
||||
(require preserves)
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
(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
|
||||
(:parse-embedded :parse-embedded:gen-schema)
|
||||
(:embedded->preserves :embedded->preserves:gen-schema)))
|
||||
(define :parse-embedded values)
|
||||
(define :embedded->preserves values)
|
||||
(:decode-embedded decode-embedded:gen-schema)
|
||||
(:encode-embedded encode-embedded:gen-schema)))
|
||||
(define :decode-embedded values)
|
||||
(define :encode-embedded values)
|
||||
(require preserves)
|
||||
(require preserves-schema/support)
|
||||
(require racket/match)
|
||||
|
|
@ -99,8 +99,8 @@
|
|||
((and dest
|
||||
(record
|
||||
'bundle
|
||||
(list (app parse-Modules (and $modules (not (== eof)))))))
|
||||
(Bundle $modules))
|
||||
(list (app parse-Modules (and ?modules (not (== eof)))))))
|
||||
(Bundle ?modules))
|
||||
(_ eof)))
|
||||
(define parse-Bundle! (parse-success-or-error 'parse-Bundle parse-Bundle)))
|
||||
(begin
|
||||
|
|
@ -111,30 +111,30 @@
|
|||
(record
|
||||
'rec
|
||||
(list
|
||||
(app parse-NamedPattern (and $label (not (== eof))))
|
||||
(app parse-NamedPattern (and $fields (not (== eof)))))))
|
||||
(CompoundPattern-rec $label $fields))
|
||||
(app parse-NamedPattern (and ?label (not (== eof))))
|
||||
(app parse-NamedPattern (and ?fields (not (== eof)))))))
|
||||
(CompoundPattern-rec ?label ?fields))
|
||||
((and dest
|
||||
(record
|
||||
'tuple
|
||||
(list
|
||||
(list
|
||||
(app parse-NamedPattern (and $patterns (not (== eof))))
|
||||
(app parse-NamedPattern (and ?patterns (not (== eof))))
|
||||
...))))
|
||||
(CompoundPattern-tuple $patterns))
|
||||
(CompoundPattern-tuple ?patterns))
|
||||
((and dest
|
||||
(record
|
||||
'tuple*
|
||||
(list
|
||||
(list (app parse-NamedPattern (and $fixed (not (== eof)))) ...)
|
||||
(app parse-NamedSimplePattern (and $variable (not (== eof)))))))
|
||||
(CompoundPattern-tuple* $fixed $variable))
|
||||
(list (app parse-NamedPattern (and ?fixed (not (== eof)))) ...)
|
||||
(app parse-NamedSimplePattern (and ?variable (not (== eof)))))))
|
||||
(CompoundPattern-tuple* ?fixed ?variable))
|
||||
((and dest
|
||||
(record
|
||||
'dict
|
||||
(list
|
||||
(app parse-DictionaryEntries (and $entries (not (== eof)))))))
|
||||
(CompoundPattern-dict $entries))
|
||||
(app parse-DictionaryEntries (and ?entries (not (== eof)))))))
|
||||
(CompoundPattern-dict ?entries))
|
||||
(_ eof)))
|
||||
(define parse-CompoundPattern!
|
||||
(parse-success-or-error 'parse-CompoundPattern parse-CompoundPattern)))
|
||||
|
|
@ -147,23 +147,23 @@
|
|||
'or
|
||||
(list
|
||||
(list*
|
||||
(app parse-NamedAlternative (and $pattern0 (not (== eof))))
|
||||
(app parse-NamedAlternative (and $pattern1 (not (== eof))))
|
||||
(app parse-NamedAlternative (and ?pattern0 (not (== eof))))
|
||||
(app parse-NamedAlternative (and ?pattern1 (not (== eof))))
|
||||
(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
|
||||
(record
|
||||
'and
|
||||
(list
|
||||
(list*
|
||||
(app parse-NamedPattern (and $pattern0 (not (== eof))))
|
||||
(app parse-NamedPattern (and $pattern1 (not (== eof))))
|
||||
(app parse-NamedPattern (and ?pattern0 (not (== eof))))
|
||||
(app parse-NamedPattern (and ?pattern1 (not (== eof))))
|
||||
(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))))
|
||||
(Definition-Pattern dest))
|
||||
(_ eof)))
|
||||
|
|
@ -240,9 +240,9 @@
|
|||
input
|
||||
((and dest
|
||||
(list
|
||||
(and $variantLabel (? string?))
|
||||
(app parse-Pattern (and $pattern (not (== eof))))))
|
||||
(NamedAlternative $variantLabel $pattern))
|
||||
(and ?variantLabel (? string?))
|
||||
(app parse-Pattern (and ?pattern (not (== eof))))))
|
||||
(NamedAlternative ?variantLabel ?pattern))
|
||||
(_ eof)))
|
||||
(define parse-NamedAlternative!
|
||||
(parse-success-or-error 'parse-NamedAlternative parse-NamedAlternative)))
|
||||
|
|
@ -278,9 +278,9 @@
|
|||
(record
|
||||
'named
|
||||
(list
|
||||
(and $name (? symbol?))
|
||||
(app parse-SimplePattern (and $pattern (not (== eof)))))))
|
||||
(NamedSimplePattern_ $name $pattern))
|
||||
(and ?name (? symbol?))
|
||||
(app parse-SimplePattern (and ?pattern (not (== eof)))))))
|
||||
(NamedSimplePattern_ ?name ?pattern))
|
||||
(_ eof)))
|
||||
(define parse-NamedSimplePattern_!
|
||||
(parse-success-or-error
|
||||
|
|
@ -305,9 +305,9 @@
|
|||
(record
|
||||
'ref
|
||||
(list
|
||||
(app parse-ModulePath (and $module (not (== eof))))
|
||||
(and $name (? symbol?)))))
|
||||
(Ref $module $name))
|
||||
(app parse-ModulePath (and ?module (not (== eof))))
|
||||
(and ?name (? symbol?)))))
|
||||
(Ref ?module ?name))
|
||||
(_ eof)))
|
||||
(define parse-Ref! (parse-success-or-error 'parse-Ref parse-Ref)))
|
||||
(begin
|
||||
|
|
@ -320,15 +320,15 @@
|
|||
(list
|
||||
(hash-table
|
||||
('definitions
|
||||
(app parse-Definitions (and $definitions (not (== eof)))))
|
||||
(app parse-Definitions (and ?definitions (not (== eof)))))
|
||||
('embeddedType
|
||||
(app
|
||||
parse-EmbeddedTypeName
|
||||
(and $embeddedType (not (== eof)))))
|
||||
('version (app parse-Version (and $version (not (== eof)))))
|
||||
(and ?embeddedType (not (== eof)))))
|
||||
('version (app parse-Version (and ?version (not (== eof)))))
|
||||
(_ _)
|
||||
...))))
|
||||
(Schema $definitions $embeddedType $version))
|
||||
(Schema ?definitions ?embeddedType ?version))
|
||||
(_ eof)))
|
||||
(define parse-Schema! (parse-success-or-error 'parse-Schema parse-Schema)))
|
||||
(begin
|
||||
|
|
@ -339,32 +339,32 @@
|
|||
((and dest
|
||||
(record
|
||||
'atom
|
||||
(list (app parse-AtomKind (and $atomKind (not (== eof)))))))
|
||||
(SimplePattern-atom $atomKind))
|
||||
(list (app parse-AtomKind (and ?atomKind (not (== eof)))))))
|
||||
(SimplePattern-atom ?atomKind))
|
||||
((and dest
|
||||
(record
|
||||
'embedded
|
||||
(list
|
||||
(app parse-SimplePattern (and $interface (not (== eof)))))))
|
||||
(SimplePattern-embedded $interface))
|
||||
((and dest (record 'lit (list $value))) (SimplePattern-lit $value))
|
||||
(app parse-SimplePattern (and ?interface (not (== eof)))))))
|
||||
(SimplePattern-embedded ?interface))
|
||||
((and dest (record 'lit (list ?value))) (SimplePattern-lit ?value))
|
||||
((and dest
|
||||
(record
|
||||
'seqof
|
||||
(list (app parse-SimplePattern (and $pattern (not (== eof)))))))
|
||||
(SimplePattern-seqof $pattern))
|
||||
(list (app parse-SimplePattern (and ?pattern (not (== eof)))))))
|
||||
(SimplePattern-seqof ?pattern))
|
||||
((and dest
|
||||
(record
|
||||
'setof
|
||||
(list (app parse-SimplePattern (and $pattern (not (== eof)))))))
|
||||
(SimplePattern-setof $pattern))
|
||||
(list (app parse-SimplePattern (and ?pattern (not (== eof)))))))
|
||||
(SimplePattern-setof ?pattern))
|
||||
((and dest
|
||||
(record
|
||||
'dictof
|
||||
(list
|
||||
(app parse-SimplePattern (and $key (not (== eof))))
|
||||
(app parse-SimplePattern (and $value (not (== eof)))))))
|
||||
(SimplePattern-dictof $key $value))
|
||||
(app parse-SimplePattern (and ?key (not (== eof))))
|
||||
(app parse-SimplePattern (and ?value (not (== eof)))))))
|
||||
(SimplePattern-dictof ?key ?value))
|
||||
((app parse-Ref (and dest (not (== eof)))) (SimplePattern-Ref dest))
|
||||
(_ eof)))
|
||||
(define parse-SimplePattern!
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide definition-parsers
|
||||
Ref-parser-name)
|
||||
Ref-parser-name
|
||||
Ref-parser!-name)
|
||||
|
||||
(require preserves)
|
||||
(require racket/match)
|
||||
|
|
@ -66,7 +67,7 @@
|
|||
[(AtomKind-ByteString) 'bytes?]
|
||||
[(AtomKind-Symbol) 'symbol?])))]
|
||||
[(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-seqof variable-pat)
|
||||
`(list ,(pattern->match-pattern variable-pat dest-pat-stx) ...)]
|
||||
|
|
@ -111,6 +112,10 @@
|
|||
(match-define (Ref module-path name) r)
|
||||
(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)
|
||||
(if (symbol? v)
|
||||
`',v
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@
|
|||
[(NamedSimplePattern_ n p) (pattern->unparser p (escape n))]
|
||||
[(SimplePattern-any) 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-seqof variable-pat)
|
||||
`(for/list [(item (in-list ,src-stx))] ,(pattern->unparser variable-pat 'item))]
|
||||
|
|
|
|||
Loading…
Reference in New Issue