Regenerate metaschema
This commit is contained in:
parent
eeb84ad669
commit
a24a5b19f5
|
|
@ -5,10 +5,64 @@
|
|||
(require racket/match)
|
||||
(require racket/set)
|
||||
(require racket/dict)
|
||||
(struct AtomKind-Symbol () #:prefab)
|
||||
(struct AtomKind-ByteString () #:prefab)
|
||||
(struct AtomKind-String () #:prefab)
|
||||
(struct AtomKind-SignedInteger () #:prefab)
|
||||
(struct AtomKind-Double () #:prefab)
|
||||
(struct AtomKind-Float () #:prefab)
|
||||
(struct AtomKind-Boolean () #:prefab)
|
||||
(define (AtomKind? p)
|
||||
(or (AtomKind-Boolean? p)
|
||||
(AtomKind-Float? p)
|
||||
(AtomKind-Double? p)
|
||||
(AtomKind-SignedInteger? p)
|
||||
(AtomKind-String? p)
|
||||
(AtomKind-ByteString? p)
|
||||
(AtomKind-Symbol? p)))
|
||||
(struct Bundle (modules) #:prefab)
|
||||
(struct CompoundPattern-dict (entries) #:prefab)
|
||||
(struct CompoundPattern-tuple* (fixed variable) #:prefab)
|
||||
(struct CompoundPattern-tuple (patterns) #:prefab)
|
||||
(struct CompoundPattern-rec (label fields) #:prefab)
|
||||
(define (CompoundPattern? p)
|
||||
(or (CompoundPattern-rec? p)
|
||||
(CompoundPattern-tuple? p)
|
||||
(CompoundPattern-tuple*? p)
|
||||
(CompoundPattern-dict? p)))
|
||||
(struct Definition-Pattern (value) #:prefab)
|
||||
(struct Definition-and (pattern0 pattern1 patternN) #:prefab)
|
||||
(struct Definition-or (pattern0 pattern1 patternN) #:prefab)
|
||||
(define (Definition? p)
|
||||
(or (Definition-or? p) (Definition-and? p) (Definition-Pattern? p)))
|
||||
(struct EmbeddedTypeName-false () #:prefab)
|
||||
(struct EmbeddedTypeName-Ref (value) #:prefab)
|
||||
(define (EmbeddedTypeName? p)
|
||||
(or (EmbeddedTypeName-Ref? p) (EmbeddedTypeName-false? p)))
|
||||
(struct NamedAlternative (variantLabel pattern) #:prefab)
|
||||
(struct NamedPattern-anonymous (value) #:prefab)
|
||||
(struct NamedPattern-named (value) #:prefab)
|
||||
(define (NamedPattern? p)
|
||||
(or (NamedPattern-named? p) (NamedPattern-anonymous? p)))
|
||||
(struct NamedPattern-named (value) #:prefab)
|
||||
(struct NamedPattern-anonymous (value) #:prefab)
|
||||
(struct NamedSimplePattern-anonymous (value) #:prefab)
|
||||
(struct NamedSimplePattern-named (value) #:prefab)
|
||||
(define (NamedSimplePattern? p)
|
||||
(or (NamedSimplePattern-named? p) (NamedSimplePattern-anonymous? p)))
|
||||
(struct NamedSimplePattern_ (name pattern) #:prefab)
|
||||
(struct Pattern-CompoundPattern (value) #:prefab)
|
||||
(struct Pattern-SimplePattern (value) #:prefab)
|
||||
(define (Pattern? p)
|
||||
(or (Pattern-SimplePattern? p) (Pattern-CompoundPattern? p)))
|
||||
(struct Ref (module name) #:prefab)
|
||||
(struct Schema (definitions embeddedType version) #:prefab)
|
||||
(struct SimplePattern-Ref (value) #:prefab)
|
||||
(struct SimplePattern-dictof (key value) #:prefab)
|
||||
(struct SimplePattern-setof (pattern) #:prefab)
|
||||
(struct SimplePattern-seqof (pattern) #:prefab)
|
||||
(struct SimplePattern-lit (value) #:prefab)
|
||||
(struct SimplePattern-embedded () #:prefab)
|
||||
(struct SimplePattern-atom (atomKind) #:prefab)
|
||||
(struct SimplePattern-any () #:prefab)
|
||||
(define (SimplePattern? p)
|
||||
(or (SimplePattern-any? p)
|
||||
(SimplePattern-atom? p)
|
||||
|
|
@ -18,346 +72,312 @@
|
|||
(SimplePattern-setof? p)
|
||||
(SimplePattern-dictof? p)
|
||||
(SimplePattern-Ref? p)))
|
||||
(struct SimplePattern-any () #:prefab)
|
||||
(struct SimplePattern-atom (atomKind) #:prefab)
|
||||
(struct SimplePattern-embedded () #:prefab)
|
||||
(struct SimplePattern-lit (value) #:prefab)
|
||||
(struct SimplePattern-seqof (pattern) #:prefab)
|
||||
(struct SimplePattern-setof (pattern) #:prefab)
|
||||
(struct SimplePattern-dictof (key value) #:prefab)
|
||||
(struct SimplePattern-Ref (value) #:prefab)
|
||||
(struct NamedAlternative (variantLabel pattern) #:prefab)
|
||||
(struct Schema (definitions embeddedType version) #:prefab)
|
||||
(define (Pattern? p)
|
||||
(or (Pattern-SimplePattern? p) (Pattern-CompoundPattern? p)))
|
||||
(struct Pattern-SimplePattern (value) #:prefab)
|
||||
(struct Pattern-CompoundPattern (value) #:prefab)
|
||||
(define (CompoundPattern? p)
|
||||
(or (CompoundPattern-rec? p)
|
||||
(CompoundPattern-tuple? p)
|
||||
(CompoundPattern-tuple*? p)
|
||||
(CompoundPattern-dict? p)))
|
||||
(struct CompoundPattern-rec (label fields) #:prefab)
|
||||
(struct CompoundPattern-tuple (patterns) #:prefab)
|
||||
(struct CompoundPattern-tuple* (fixed variable) #:prefab)
|
||||
(struct CompoundPattern-dict (entries) #:prefab)
|
||||
(struct Ref (module name) #:prefab)
|
||||
(struct Bundle (modules) #:prefab)
|
||||
(struct NamedSimplePattern_ (name pattern) #:prefab)
|
||||
(define (Definition? p)
|
||||
(or (Definition-or? p) (Definition-and? p) (Definition-Pattern? p)))
|
||||
(struct Definition-or (pattern0 pattern1 patternN) #:prefab)
|
||||
(struct Definition-and (pattern0 pattern1 patternN) #:prefab)
|
||||
(struct Definition-Pattern (value) #:prefab)
|
||||
(define (NamedSimplePattern? p)
|
||||
(or (NamedSimplePattern-named? p) (NamedSimplePattern-anonymous? p)))
|
||||
(struct NamedSimplePattern-named (value) #:prefab)
|
||||
(struct NamedSimplePattern-anonymous (value) #:prefab)
|
||||
(define (EmbeddedTypeName? p)
|
||||
(or (EmbeddedTypeName-Ref? p) (EmbeddedTypeName-false? p)))
|
||||
(struct EmbeddedTypeName-Ref (value) #:prefab)
|
||||
(struct EmbeddedTypeName-false () #:prefab)
|
||||
(define (AtomKind? p)
|
||||
(or (AtomKind-Boolean? p)
|
||||
(AtomKind-Float? p)
|
||||
(AtomKind-Double? p)
|
||||
(AtomKind-SignedInteger? p)
|
||||
(AtomKind-String? p)
|
||||
(AtomKind-ByteString? p)
|
||||
(AtomKind-Symbol? p)))
|
||||
(struct AtomKind-Boolean () #:prefab)
|
||||
(struct AtomKind-Float () #:prefab)
|
||||
(struct AtomKind-Double () #:prefab)
|
||||
(struct AtomKind-SignedInteger () #:prefab)
|
||||
(struct AtomKind-String () #:prefab)
|
||||
(struct AtomKind-ByteString () #:prefab)
|
||||
(struct AtomKind-Symbol () #:prefab)
|
||||
(define (parse-NamedPattern input)
|
||||
(match
|
||||
input
|
||||
((app parse-NamedSimplePattern_ (and dest (not (== eof))))
|
||||
(NamedPattern-named dest))
|
||||
((app parse-Pattern (and dest (not (== eof))))
|
||||
(NamedPattern-anonymous dest))
|
||||
(_ eof)))
|
||||
(define (parse-SimplePattern input)
|
||||
(match
|
||||
input
|
||||
((and dest 'any) (SimplePattern-any))
|
||||
((and dest
|
||||
(record
|
||||
'atom
|
||||
(list (app parse-AtomKind (and $atomKind (not (== eof)))))))
|
||||
(SimplePattern-atom $atomKind))
|
||||
((and dest (record 'embedded (list))) (SimplePattern-embedded))
|
||||
((and dest (record 'lit (list $value))) (SimplePattern-lit $value))
|
||||
((and dest
|
||||
(record
|
||||
'seqof
|
||||
(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))
|
||||
((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-Ref (and dest (not (== eof)))) (SimplePattern-Ref dest))
|
||||
(_ eof)))
|
||||
(define (parse-NamedAlternative input)
|
||||
(match
|
||||
input
|
||||
((and dest
|
||||
(list
|
||||
(and $variantLabel (? string?))
|
||||
(app parse-Pattern (and $pattern (not (== eof))))))
|
||||
(NamedAlternative $variantLabel $pattern))
|
||||
(_ eof)))
|
||||
(define (parse-Definitions input)
|
||||
(match
|
||||
input
|
||||
((parse-sequence
|
||||
dict?
|
||||
dict->list
|
||||
(cons
|
||||
(and key (? symbol?))
|
||||
(app parse-Definition (and value (not (== eof)))))
|
||||
(cons key value)
|
||||
make-immutable-hash
|
||||
dest)
|
||||
dest)
|
||||
(_ eof)))
|
||||
(define (parse-Schema input)
|
||||
(match
|
||||
input
|
||||
((and dest
|
||||
(record
|
||||
'schema
|
||||
(list
|
||||
(hash-table
|
||||
('definitions
|
||||
(app parse-Definitions (and $definitions (not (== eof)))))
|
||||
('embeddedType
|
||||
(app parse-EmbeddedTypeName (and $embeddedType (not (== eof)))))
|
||||
('version (app parse-Version (and $version (not (== eof)))))
|
||||
(_ _)
|
||||
...))))
|
||||
(Schema $definitions $embeddedType $version))
|
||||
(_ eof)))
|
||||
(define (parse-Pattern input)
|
||||
(match
|
||||
input
|
||||
((app parse-SimplePattern (and dest (not (== eof))))
|
||||
(Pattern-SimplePattern dest))
|
||||
((app parse-CompoundPattern (and dest (not (== eof))))
|
||||
(Pattern-CompoundPattern dest))
|
||||
(_ eof)))
|
||||
(define (parse-CompoundPattern input)
|
||||
(match
|
||||
input
|
||||
((and dest
|
||||
(record
|
||||
'rec
|
||||
(list
|
||||
(app parse-NamedPattern (and $label (not (== eof))))
|
||||
(app parse-NamedPattern (and $fields (not (== eof)))))))
|
||||
(CompoundPattern-rec $label $fields))
|
||||
((and dest
|
||||
(record
|
||||
'tuple
|
||||
(list
|
||||
(begin
|
||||
(define (parse-AtomKind input)
|
||||
(match
|
||||
input
|
||||
((and dest 'Boolean) (AtomKind-Boolean))
|
||||
((and dest 'Float) (AtomKind-Float))
|
||||
((and dest 'Double) (AtomKind-Double))
|
||||
((and dest 'SignedInteger) (AtomKind-SignedInteger))
|
||||
((and dest 'String) (AtomKind-String))
|
||||
((and dest 'ByteString) (AtomKind-ByteString))
|
||||
((and dest 'Symbol) (AtomKind-Symbol))
|
||||
(_ eof)))
|
||||
(define parse-AtomKind!
|
||||
(parse-success-or-error 'parse-AtomKind parse-AtomKind)))
|
||||
(begin
|
||||
(define (parse-Bundle input)
|
||||
(match
|
||||
input
|
||||
((and dest
|
||||
(record
|
||||
'bundle
|
||||
(list (app parse-Modules (and $modules (not (== eof)))))))
|
||||
(Bundle $modules))
|
||||
(_ eof)))
|
||||
(define parse-Bundle! (parse-success-or-error 'parse-Bundle parse-Bundle)))
|
||||
(begin
|
||||
(define (parse-CompoundPattern input)
|
||||
(match
|
||||
input
|
||||
((and dest
|
||||
(record
|
||||
'rec
|
||||
(list
|
||||
(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))))
|
||||
...))))
|
||||
(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))
|
||||
((and dest
|
||||
(record
|
||||
'dict
|
||||
(list
|
||||
(app parse-DictionaryEntries (and $entries (not (== eof)))))))
|
||||
(CompoundPattern-dict $entries))
|
||||
(_ eof)))
|
||||
(define parse-CompoundPattern!
|
||||
(parse-success-or-error 'parse-CompoundPattern parse-CompoundPattern)))
|
||||
(begin
|
||||
(define (parse-Definition input)
|
||||
(match
|
||||
input
|
||||
((and dest
|
||||
(record
|
||||
'or
|
||||
(list
|
||||
(list*
|
||||
(app parse-NamedAlternative (and $pattern0 (not (== eof))))
|
||||
(app parse-NamedAlternative (and $pattern1 (not (== eof))))
|
||||
(list
|
||||
(app parse-NamedAlternative (and $patternN (not (== eof))))
|
||||
...)))))
|
||||
(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))))
|
||||
(list
|
||||
(app parse-NamedPattern (and $patternN (not (== eof))))
|
||||
...)))))
|
||||
(Definition-and $pattern0 $pattern1 $patternN))
|
||||
((app parse-Pattern (and dest (not (== eof))))
|
||||
(Definition-Pattern dest))
|
||||
(_ eof)))
|
||||
(define parse-Definition!
|
||||
(parse-success-or-error 'parse-Definition parse-Definition)))
|
||||
(begin
|
||||
(define (parse-Definitions input)
|
||||
(match
|
||||
input
|
||||
((parse-sequence
|
||||
dict?
|
||||
dict->list
|
||||
(cons
|
||||
(and key (? symbol?))
|
||||
(app parse-Definition (and value (not (== eof)))))
|
||||
(cons key value)
|
||||
make-immutable-hash
|
||||
dest)
|
||||
dest)
|
||||
(_ eof)))
|
||||
(define parse-Definitions!
|
||||
(parse-success-or-error 'parse-Definitions parse-Definitions)))
|
||||
(begin
|
||||
(define (parse-DictionaryEntries input)
|
||||
(match
|
||||
input
|
||||
((parse-sequence
|
||||
dict?
|
||||
dict->list
|
||||
(cons key (app parse-NamedSimplePattern (and value (not (== eof)))))
|
||||
(cons key value)
|
||||
make-immutable-hash
|
||||
dest)
|
||||
dest)
|
||||
(_ eof)))
|
||||
(define parse-DictionaryEntries!
|
||||
(parse-success-or-error
|
||||
'parse-DictionaryEntries
|
||||
parse-DictionaryEntries)))
|
||||
(begin
|
||||
(define (parse-EmbeddedTypeName input)
|
||||
(match
|
||||
input
|
||||
((app parse-Ref (and dest (not (== eof)))) (EmbeddedTypeName-Ref dest))
|
||||
((and dest (== '#f)) (EmbeddedTypeName-false))
|
||||
(_ eof)))
|
||||
(define parse-EmbeddedTypeName!
|
||||
(parse-success-or-error 'parse-EmbeddedTypeName parse-EmbeddedTypeName)))
|
||||
(begin
|
||||
(define (parse-ModulePath input)
|
||||
(match input ((list (and dest (? symbol?)) ...) dest) (_ eof)))
|
||||
(define parse-ModulePath!
|
||||
(parse-success-or-error 'parse-ModulePath parse-ModulePath)))
|
||||
(begin
|
||||
(define (parse-Modules input)
|
||||
(match
|
||||
input
|
||||
((parse-sequence
|
||||
dict?
|
||||
dict->list
|
||||
(cons
|
||||
(app parse-ModulePath (and key (not (== eof))))
|
||||
(app parse-Schema (and value (not (== eof)))))
|
||||
(cons key value)
|
||||
make-immutable-hash
|
||||
dest)
|
||||
dest)
|
||||
(_ eof)))
|
||||
(define parse-Modules!
|
||||
(parse-success-or-error 'parse-Modules parse-Modules)))
|
||||
(begin
|
||||
(define (parse-NamedAlternative input)
|
||||
(match
|
||||
input
|
||||
((and dest
|
||||
(list
|
||||
(app parse-NamedPattern (and $patterns (not (== eof))))
|
||||
...))))
|
||||
(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))
|
||||
((and dest
|
||||
(record
|
||||
'dict
|
||||
(list
|
||||
(app parse-DictionaryEntries (and $entries (not (== eof)))))))
|
||||
(CompoundPattern-dict $entries))
|
||||
(_ eof)))
|
||||
(define (parse-Modules input)
|
||||
(match
|
||||
input
|
||||
((parse-sequence
|
||||
dict?
|
||||
dict->list
|
||||
(cons
|
||||
(app parse-ModulePath (and key (not (== eof))))
|
||||
(app parse-Schema (and value (not (== eof)))))
|
||||
(cons key value)
|
||||
make-immutable-hash
|
||||
dest)
|
||||
dest)
|
||||
(_ eof)))
|
||||
(define (parse-Ref input)
|
||||
(match
|
||||
input
|
||||
((and dest
|
||||
(record
|
||||
'ref
|
||||
(list
|
||||
(app parse-ModulePath (and $module (not (== eof))))
|
||||
(and $name (? symbol?)))))
|
||||
(Ref $module $name))
|
||||
(_ eof)))
|
||||
(define (parse-Bundle input)
|
||||
(match
|
||||
input
|
||||
((and dest
|
||||
(record
|
||||
'bundle
|
||||
(list (app parse-Modules (and $modules (not (== eof)))))))
|
||||
(Bundle $modules))
|
||||
(_ eof)))
|
||||
(define (parse-NamedSimplePattern_ input)
|
||||
(match
|
||||
input
|
||||
((and dest
|
||||
(record
|
||||
'named
|
||||
(list
|
||||
(and $name (? symbol?))
|
||||
(app parse-SimplePattern (and $pattern (not (== eof)))))))
|
||||
(NamedSimplePattern_ $name $pattern))
|
||||
(_ eof)))
|
||||
(define (parse-Definition input)
|
||||
(match
|
||||
input
|
||||
((and dest
|
||||
(record
|
||||
'or
|
||||
(list
|
||||
(list*
|
||||
(app parse-NamedAlternative (and $pattern0 (not (== eof))))
|
||||
(app parse-NamedAlternative (and $pattern1 (not (== eof))))
|
||||
(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)))
|
||||
(begin
|
||||
(define (parse-NamedPattern input)
|
||||
(match
|
||||
input
|
||||
((app parse-NamedSimplePattern_ (and dest (not (== eof))))
|
||||
(NamedPattern-named dest))
|
||||
((app parse-Pattern (and dest (not (== eof))))
|
||||
(NamedPattern-anonymous dest))
|
||||
(_ eof)))
|
||||
(define parse-NamedPattern!
|
||||
(parse-success-or-error 'parse-NamedPattern parse-NamedPattern)))
|
||||
(begin
|
||||
(define (parse-NamedSimplePattern input)
|
||||
(match
|
||||
input
|
||||
((app parse-NamedSimplePattern_ (and dest (not (== eof))))
|
||||
(NamedSimplePattern-named dest))
|
||||
((app parse-SimplePattern (and dest (not (== eof))))
|
||||
(NamedSimplePattern-anonymous dest))
|
||||
(_ eof)))
|
||||
(define parse-NamedSimplePattern!
|
||||
(parse-success-or-error
|
||||
'parse-NamedSimplePattern
|
||||
parse-NamedSimplePattern)))
|
||||
(begin
|
||||
(define (parse-NamedSimplePattern_ input)
|
||||
(match
|
||||
input
|
||||
((and dest
|
||||
(record
|
||||
'named
|
||||
(list
|
||||
(app parse-NamedAlternative (and $patternN (not (== eof))))
|
||||
...)))))
|
||||
(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))))
|
||||
(and $name (? symbol?))
|
||||
(app parse-SimplePattern (and $pattern (not (== eof)))))))
|
||||
(NamedSimplePattern_ $name $pattern))
|
||||
(_ eof)))
|
||||
(define parse-NamedSimplePattern_!
|
||||
(parse-success-or-error
|
||||
'parse-NamedSimplePattern_
|
||||
parse-NamedSimplePattern_)))
|
||||
(begin
|
||||
(define (parse-Pattern input)
|
||||
(match
|
||||
input
|
||||
((app parse-SimplePattern (and dest (not (== eof))))
|
||||
(Pattern-SimplePattern dest))
|
||||
((app parse-CompoundPattern (and dest (not (== eof))))
|
||||
(Pattern-CompoundPattern dest))
|
||||
(_ eof)))
|
||||
(define parse-Pattern!
|
||||
(parse-success-or-error 'parse-Pattern parse-Pattern)))
|
||||
(begin
|
||||
(define (parse-Ref input)
|
||||
(match
|
||||
input
|
||||
((and dest
|
||||
(record
|
||||
'ref
|
||||
(list
|
||||
(app parse-NamedPattern (and $patternN (not (== eof))))
|
||||
...)))))
|
||||
(Definition-and $pattern0 $pattern1 $patternN))
|
||||
((app parse-Pattern (and dest (not (== eof)))) (Definition-Pattern dest))
|
||||
(_ eof)))
|
||||
(define (parse-NamedSimplePattern input)
|
||||
(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
|
||||
(define (parse-Schema input)
|
||||
(match
|
||||
input
|
||||
((and dest
|
||||
(record
|
||||
'schema
|
||||
(list
|
||||
(hash-table
|
||||
('definitions
|
||||
(app parse-Definitions (and $definitions (not (== eof)))))
|
||||
('embeddedType
|
||||
(app
|
||||
parse-EmbeddedTypeName
|
||||
(and $embeddedType (not (== eof)))))
|
||||
('version (app parse-Version (and $version (not (== eof)))))
|
||||
(_ _)
|
||||
...))))
|
||||
(Schema $definitions $embeddedType $version))
|
||||
(_ eof)))
|
||||
(define parse-Schema! (parse-success-or-error 'parse-Schema parse-Schema)))
|
||||
(begin
|
||||
(define (parse-SimplePattern input)
|
||||
(match
|
||||
input
|
||||
((and dest 'any) (SimplePattern-any))
|
||||
((and dest
|
||||
(record
|
||||
'atom
|
||||
(list (app parse-AtomKind (and $atomKind (not (== eof)))))))
|
||||
(SimplePattern-atom $atomKind))
|
||||
((and dest (record 'embedded (list))) (SimplePattern-embedded))
|
||||
((and dest (record 'lit (list $value))) (SimplePattern-lit $value))
|
||||
((and dest
|
||||
(record
|
||||
'seqof
|
||||
(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))
|
||||
((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-Ref (and dest (not (== eof)))) (SimplePattern-Ref dest))
|
||||
(_ eof)))
|
||||
(define parse-SimplePattern!
|
||||
(parse-success-or-error 'parse-SimplePattern parse-SimplePattern)))
|
||||
(begin
|
||||
(define (parse-Version input)
|
||||
(match input ((and dest (== '1)) (void)) (_ eof)))
|
||||
(define parse-Version!
|
||||
(parse-success-or-error 'parse-Version parse-Version)))
|
||||
(define (AtomKind->preserves input)
|
||||
(match
|
||||
input
|
||||
((app parse-NamedSimplePattern_ (and dest (not (== eof))))
|
||||
(NamedSimplePattern-named dest))
|
||||
((app parse-SimplePattern (and dest (not (== eof))))
|
||||
(NamedSimplePattern-anonymous dest))
|
||||
(_ eof)))
|
||||
(define (parse-EmbeddedTypeName input)
|
||||
((AtomKind-Boolean) 'Boolean)
|
||||
((AtomKind-Float) 'Float)
|
||||
((AtomKind-Double) 'Double)
|
||||
((AtomKind-SignedInteger) 'SignedInteger)
|
||||
((AtomKind-String) 'String)
|
||||
((AtomKind-ByteString) 'ByteString)
|
||||
((AtomKind-Symbol) 'Symbol)))
|
||||
(define (Bundle->preserves input)
|
||||
(match
|
||||
input
|
||||
((app parse-Ref (and dest (not (== eof)))) (EmbeddedTypeName-Ref dest))
|
||||
((and dest (== '#f)) (EmbeddedTypeName-false))
|
||||
(_ eof)))
|
||||
(define (parse-ModulePath input)
|
||||
(match input ((list (and dest (? symbol?)) ...) dest) (_ eof)))
|
||||
(define (parse-AtomKind input)
|
||||
(match
|
||||
input
|
||||
((and dest 'Boolean) (AtomKind-Boolean))
|
||||
((and dest 'Float) (AtomKind-Float))
|
||||
((and dest 'Double) (AtomKind-Double))
|
||||
((and dest 'SignedInteger) (AtomKind-SignedInteger))
|
||||
((and dest 'String) (AtomKind-String))
|
||||
((and dest 'ByteString) (AtomKind-ByteString))
|
||||
((and dest 'Symbol) (AtomKind-Symbol))
|
||||
(_ eof)))
|
||||
(define (parse-DictionaryEntries input)
|
||||
(match
|
||||
input
|
||||
((parse-sequence
|
||||
dict?
|
||||
dict->list
|
||||
(cons key (app parse-NamedSimplePattern (and value (not (== eof)))))
|
||||
(cons key value)
|
||||
make-immutable-hash
|
||||
dest)
|
||||
dest)
|
||||
(_ eof)))
|
||||
(define (parse-Version input)
|
||||
(match input ((and dest (== '1)) (void)) (_ eof)))
|
||||
(define (NamedPattern->preserves input)
|
||||
(match
|
||||
input
|
||||
((NamedPattern-named src) (NamedSimplePattern_->preserves src))
|
||||
((NamedPattern-anonymous src) (Pattern->preserves src))))
|
||||
(define (SimplePattern->preserves input)
|
||||
(match
|
||||
input
|
||||
((SimplePattern-any) 'any)
|
||||
((SimplePattern-atom $atomKind)
|
||||
(record 'atom (list (AtomKind->preserves $atomKind))))
|
||||
((SimplePattern-embedded) (record 'embedded (list)))
|
||||
((SimplePattern-lit $value) (record 'lit (list $value)))
|
||||
((SimplePattern-seqof $pattern)
|
||||
(record 'seqof (list (SimplePattern->preserves $pattern))))
|
||||
((SimplePattern-setof $pattern)
|
||||
(record 'setof (list (SimplePattern->preserves $pattern))))
|
||||
((SimplePattern-dictof $key $value)
|
||||
(record
|
||||
'dictof
|
||||
(list
|
||||
(SimplePattern->preserves $key)
|
||||
(SimplePattern->preserves $value))))
|
||||
((SimplePattern-Ref src) (Ref->preserves src))))
|
||||
(define (NamedAlternative->preserves input)
|
||||
(match
|
||||
input
|
||||
((NamedAlternative $variantLabel $pattern)
|
||||
(list $variantLabel (Pattern->preserves $pattern)))))
|
||||
(define (Definitions->preserves input)
|
||||
(match
|
||||
input
|
||||
(src
|
||||
(for/hash
|
||||
(((key value) (in-dict src)))
|
||||
(values key (Definition->preserves value))))))
|
||||
(define (Schema->preserves input)
|
||||
(match
|
||||
input
|
||||
((Schema $definitions $embeddedType $version)
|
||||
(record
|
||||
'schema
|
||||
(list
|
||||
(hash
|
||||
'definitions
|
||||
(Definitions->preserves $definitions)
|
||||
'embeddedType
|
||||
(EmbeddedTypeName->preserves $embeddedType)
|
||||
'version
|
||||
(Version->preserves $version)))))))
|
||||
(define (Pattern->preserves input)
|
||||
(match
|
||||
input
|
||||
((Pattern-SimplePattern src) (SimplePattern->preserves src))
|
||||
((Pattern-CompoundPattern src) (CompoundPattern->preserves src))))
|
||||
((Bundle $modules)
|
||||
(record 'bundle (list (Modules->preserves $modules))))))
|
||||
(define (CompoundPattern->preserves input)
|
||||
(match
|
||||
input
|
||||
|
|
@ -382,28 +402,6 @@
|
|||
(NamedSimplePattern->preserves $variable))))
|
||||
((CompoundPattern-dict $entries)
|
||||
(record 'dict (list (DictionaryEntries->preserves $entries))))))
|
||||
(define (Modules->preserves input)
|
||||
(match
|
||||
input
|
||||
(src
|
||||
(for/hash
|
||||
(((key value) (in-dict src)))
|
||||
(values (ModulePath->preserves key) (Schema->preserves value))))))
|
||||
(define (Ref->preserves input)
|
||||
(match
|
||||
input
|
||||
((Ref $module $name)
|
||||
(record 'ref (list (ModulePath->preserves $module) $name)))))
|
||||
(define (Bundle->preserves input)
|
||||
(match
|
||||
input
|
||||
((Bundle $modules)
|
||||
(record 'bundle (list (Modules->preserves $modules))))))
|
||||
(define (NamedSimplePattern_->preserves input)
|
||||
(match
|
||||
input
|
||||
((NamedSimplePattern_ $name $pattern)
|
||||
(record 'named (list $name (SimplePattern->preserves $pattern))))))
|
||||
(define (Definition->preserves input)
|
||||
(match
|
||||
input
|
||||
|
|
@ -428,28 +426,13 @@
|
|||
((item (in-list $patternN)))
|
||||
(NamedPattern->preserves item))))))
|
||||
((Definition-Pattern src) (Pattern->preserves src))))
|
||||
(define (NamedSimplePattern->preserves input)
|
||||
(define (Definitions->preserves input)
|
||||
(match
|
||||
input
|
||||
((NamedSimplePattern-named src) (NamedSimplePattern_->preserves src))
|
||||
((NamedSimplePattern-anonymous src) (SimplePattern->preserves src))))
|
||||
(define (EmbeddedTypeName->preserves input)
|
||||
(match
|
||||
input
|
||||
((EmbeddedTypeName-Ref src) (Ref->preserves src))
|
||||
((EmbeddedTypeName-false) '#f)))
|
||||
(define (ModulePath->preserves input)
|
||||
(match input (src (for/list ((item (in-list src))) item))))
|
||||
(define (AtomKind->preserves input)
|
||||
(match
|
||||
input
|
||||
((AtomKind-Boolean) 'Boolean)
|
||||
((AtomKind-Float) 'Float)
|
||||
((AtomKind-Double) 'Double)
|
||||
((AtomKind-SignedInteger) 'SignedInteger)
|
||||
((AtomKind-String) 'String)
|
||||
((AtomKind-ByteString) 'ByteString)
|
||||
((AtomKind-Symbol) 'Symbol)))
|
||||
(src
|
||||
(for/hash
|
||||
(((key value) (in-dict src)))
|
||||
(values key (Definition->preserves value))))))
|
||||
(define (DictionaryEntries->preserves input)
|
||||
(match
|
||||
input
|
||||
|
|
@ -457,4 +440,81 @@
|
|||
(for/hash
|
||||
(((key value) (in-dict src)))
|
||||
(values key (NamedSimplePattern->preserves value))))))
|
||||
(define (EmbeddedTypeName->preserves input)
|
||||
(match
|
||||
input
|
||||
((EmbeddedTypeName-Ref src) (Ref->preserves src))
|
||||
((EmbeddedTypeName-false) '#f)))
|
||||
(define (ModulePath->preserves input)
|
||||
(match input (src (for/list ((item (in-list src))) item))))
|
||||
(define (Modules->preserves input)
|
||||
(match
|
||||
input
|
||||
(src
|
||||
(for/hash
|
||||
(((key value) (in-dict src)))
|
||||
(values (ModulePath->preserves key) (Schema->preserves value))))))
|
||||
(define (NamedAlternative->preserves input)
|
||||
(match
|
||||
input
|
||||
((NamedAlternative $variantLabel $pattern)
|
||||
(list $variantLabel (Pattern->preserves $pattern)))))
|
||||
(define (NamedPattern->preserves input)
|
||||
(match
|
||||
input
|
||||
((NamedPattern-named src) (NamedSimplePattern_->preserves src))
|
||||
((NamedPattern-anonymous src) (Pattern->preserves src))))
|
||||
(define (NamedSimplePattern->preserves input)
|
||||
(match
|
||||
input
|
||||
((NamedSimplePattern-named src) (NamedSimplePattern_->preserves src))
|
||||
((NamedSimplePattern-anonymous src) (SimplePattern->preserves src))))
|
||||
(define (NamedSimplePattern_->preserves input)
|
||||
(match
|
||||
input
|
||||
((NamedSimplePattern_ $name $pattern)
|
||||
(record 'named (list $name (SimplePattern->preserves $pattern))))))
|
||||
(define (Pattern->preserves input)
|
||||
(match
|
||||
input
|
||||
((Pattern-SimplePattern src) (SimplePattern->preserves src))
|
||||
((Pattern-CompoundPattern src) (CompoundPattern->preserves src))))
|
||||
(define (Ref->preserves input)
|
||||
(match
|
||||
input
|
||||
((Ref $module $name)
|
||||
(record 'ref (list (ModulePath->preserves $module) $name)))))
|
||||
(define (Schema->preserves input)
|
||||
(match
|
||||
input
|
||||
((Schema $definitions $embeddedType $version)
|
||||
(record
|
||||
'schema
|
||||
(list
|
||||
(hash
|
||||
'definitions
|
||||
(Definitions->preserves $definitions)
|
||||
'embeddedType
|
||||
(EmbeddedTypeName->preserves $embeddedType)
|
||||
'version
|
||||
(Version->preserves $version)))))))
|
||||
(define (SimplePattern->preserves input)
|
||||
(match
|
||||
input
|
||||
((SimplePattern-any) 'any)
|
||||
((SimplePattern-atom $atomKind)
|
||||
(record 'atom (list (AtomKind->preserves $atomKind))))
|
||||
((SimplePattern-embedded) (record 'embedded (list)))
|
||||
((SimplePattern-lit $value) (record 'lit (list $value)))
|
||||
((SimplePattern-seqof $pattern)
|
||||
(record 'seqof (list (SimplePattern->preserves $pattern))))
|
||||
((SimplePattern-setof $pattern)
|
||||
(record 'setof (list (SimplePattern->preserves $pattern))))
|
||||
((SimplePattern-dictof $key $value)
|
||||
(record
|
||||
'dictof
|
||||
(list
|
||||
(SimplePattern->preserves $key)
|
||||
(SimplePattern->preserves $value))))
|
||||
((SimplePattern-Ref src) (Ref->preserves src))))
|
||||
(define (Version->preserves input) (match input ((? void?) '1))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue