2021-05-22 13:43:29 +00:00
|
|
|
(module gen-schema racket/base
|
2021-06-08 07:27:03 +00:00
|
|
|
(provide (except-out (all-defined-out) :decode-embedded :encode-embedded)
|
2021-06-01 14:10:04 +00:00
|
|
|
(rename-out
|
2021-06-08 07:27:03 +00:00
|
|
|
(:decode-embedded decode-embedded:gen-schema)
|
|
|
|
(:encode-embedded encode-embedded:gen-schema)))
|
2021-05-22 13:43:29 +00:00
|
|
|
(require preserves)
|
2021-06-08 13:26:32 +00:00
|
|
|
(require preserves-schema/methods)
|
2021-05-22 13:43:29 +00:00
|
|
|
(require preserves-schema/support)
|
|
|
|
(require racket/match)
|
|
|
|
(require racket/set)
|
|
|
|
(require racket/dict)
|
2021-06-08 13:26:32 +00:00
|
|
|
(require (only-in racket/generic define/generic))
|
|
|
|
(define :decode-embedded values)
|
|
|
|
(define :encode-embedded values)
|
2021-05-25 09:06:40 +00:00
|
|
|
(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)))
|
2021-06-08 13:26:32 +00:00
|
|
|
(struct
|
|
|
|
AtomKind-Boolean
|
|
|
|
()
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((AtomKind-Boolean) 'Boolean)))))
|
|
|
|
(struct
|
|
|
|
AtomKind-Float
|
|
|
|
()
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((AtomKind-Float) 'Float)))))
|
|
|
|
(struct
|
|
|
|
AtomKind-Double
|
|
|
|
()
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((AtomKind-Double) 'Double)))))
|
|
|
|
(struct
|
|
|
|
AtomKind-SignedInteger
|
|
|
|
()
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((AtomKind-SignedInteger) 'SignedInteger)))))
|
|
|
|
(struct
|
|
|
|
AtomKind-String
|
|
|
|
()
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((AtomKind-String) 'String)))))
|
|
|
|
(struct
|
|
|
|
AtomKind-ByteString
|
|
|
|
()
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((AtomKind-ByteString) 'ByteString)))))
|
|
|
|
(struct
|
|
|
|
AtomKind-Symbol
|
|
|
|
()
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((AtomKind-Symbol) 'Symbol)))))
|
|
|
|
(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))
|
2021-06-25 08:25:26 +00:00
|
|
|
(struct
|
|
|
|
Binding
|
|
|
|
(name pattern)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match
|
|
|
|
preservable
|
|
|
|
((Binding ?name ?pattern)
|
|
|
|
(record 'named (list (*->preserve ?name) (*->preserve ?pattern))))))))
|
|
|
|
(define (parse-Binding input)
|
|
|
|
(match
|
|
|
|
input
|
|
|
|
((and dest
|
|
|
|
(record
|
|
|
|
'named
|
|
|
|
(list
|
|
|
|
(and ?name (? symbol?))
|
|
|
|
(app parse-SimplePattern (and ?pattern (not (== eof)))))))
|
|
|
|
(Binding ?name ?pattern))
|
|
|
|
(_ eof)))
|
|
|
|
(define parse-Binding! (parse-success-or-error 'parse-Binding parse-Binding))
|
2021-06-08 13:26:32 +00:00
|
|
|
(struct
|
|
|
|
Bundle
|
|
|
|
(modules)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match
|
|
|
|
preservable
|
|
|
|
((Bundle ?modules) (record 'bundle (list (*->preserve ?modules))))))))
|
|
|
|
(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))
|
2021-05-25 09:06:40 +00:00
|
|
|
(define (CompoundPattern? p)
|
|
|
|
(or (CompoundPattern-rec? p)
|
|
|
|
(CompoundPattern-tuple? p)
|
2021-06-25 07:45:07 +00:00
|
|
|
(CompoundPattern-tuplePrefix? p)
|
2021-05-25 09:06:40 +00:00
|
|
|
(CompoundPattern-dict? p)))
|
2021-06-08 13:26:32 +00:00
|
|
|
(struct
|
|
|
|
CompoundPattern-rec
|
|
|
|
(label fields)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
2021-05-25 09:06:40 +00:00
|
|
|
(match
|
2021-06-08 13:26:32 +00:00
|
|
|
preservable
|
|
|
|
((CompoundPattern-rec ?label ?fields)
|
|
|
|
(record 'rec (list (*->preserve ?label) (*->preserve ?fields))))))))
|
|
|
|
(struct
|
|
|
|
CompoundPattern-tuple
|
|
|
|
(patterns)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
2021-05-25 09:06:40 +00:00
|
|
|
(match
|
2021-06-08 13:26:32 +00:00
|
|
|
preservable
|
|
|
|
((CompoundPattern-tuple ?patterns)
|
|
|
|
(record
|
|
|
|
'tuple
|
|
|
|
(list
|
|
|
|
(for/list ((item (in-list ?patterns))) (*->preserve item)))))))))
|
|
|
|
(struct
|
2021-06-25 07:45:07 +00:00
|
|
|
CompoundPattern-tuplePrefix
|
2021-06-08 13:26:32 +00:00
|
|
|
(fixed variable)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
2021-05-25 09:06:40 +00:00
|
|
|
(match
|
2021-06-08 13:26:32 +00:00
|
|
|
preservable
|
2021-06-25 07:45:07 +00:00
|
|
|
((CompoundPattern-tuplePrefix ?fixed ?variable)
|
2021-06-08 13:26:32 +00:00
|
|
|
(record
|
2021-06-25 07:45:07 +00:00
|
|
|
'tuplePrefix
|
2021-06-08 13:26:32 +00:00
|
|
|
(list
|
|
|
|
(for/list ((item (in-list ?fixed))) (*->preserve item))
|
|
|
|
(*->preserve ?variable))))))))
|
|
|
|
(struct
|
|
|
|
CompoundPattern-dict
|
|
|
|
(entries)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
2021-05-25 09:06:40 +00:00
|
|
|
(match
|
2021-06-08 13:26:32 +00:00
|
|
|
preservable
|
|
|
|
((CompoundPattern-dict ?entries)
|
|
|
|
(record 'dict (list (*->preserve ?entries))))))))
|
|
|
|
(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
|
2021-05-24 08:09:17 +00:00
|
|
|
(list
|
2021-06-08 13:26:32 +00:00
|
|
|
(app parse-NamedPattern (and ?patterns (not (== eof))))
|
|
|
|
...))))
|
|
|
|
(CompoundPattern-tuple ?patterns))
|
|
|
|
((and dest
|
|
|
|
(record
|
2021-06-25 07:45:07 +00:00
|
|
|
'tuplePrefix
|
2021-06-08 13:26:32 +00:00
|
|
|
(list
|
|
|
|
(list (app parse-NamedPattern (and ?fixed (not (== eof)))) ...)
|
|
|
|
(app parse-NamedSimplePattern (and ?variable (not (== eof)))))))
|
2021-06-25 07:45:07 +00:00
|
|
|
(CompoundPattern-tuplePrefix ?fixed ?variable))
|
2021-06-08 13:26:32 +00:00
|
|
|
((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))
|
|
|
|
(define (Definition? p)
|
|
|
|
(or (Definition-or? p) (Definition-and? p) (Definition-Pattern? p)))
|
|
|
|
(struct
|
|
|
|
Definition-or
|
|
|
|
(pattern0 pattern1 patternN)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
2021-05-25 09:06:40 +00:00
|
|
|
(match
|
2021-06-08 13:26:32 +00:00
|
|
|
preservable
|
|
|
|
((Definition-or ?pattern0 ?pattern1 ?patternN)
|
|
|
|
(record
|
|
|
|
'or
|
|
|
|
(list
|
|
|
|
(list*
|
|
|
|
(*->preserve ?pattern0)
|
|
|
|
(*->preserve ?pattern1)
|
|
|
|
(for/list ((item (in-list ?patternN))) (*->preserve item))))))))))
|
|
|
|
(struct
|
|
|
|
Definition-and
|
|
|
|
(pattern0 pattern1 patternN)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
2021-05-25 09:06:40 +00:00
|
|
|
(match
|
2021-06-08 13:26:32 +00:00
|
|
|
preservable
|
|
|
|
((Definition-and ?pattern0 ?pattern1 ?patternN)
|
|
|
|
(record
|
|
|
|
'and
|
|
|
|
(list
|
|
|
|
(list*
|
|
|
|
(*->preserve ?pattern0)
|
|
|
|
(*->preserve ?pattern1)
|
|
|
|
(for/list ((item (in-list ?patternN))) (*->preserve item))))))))))
|
|
|
|
(struct
|
|
|
|
Definition-Pattern
|
|
|
|
(value)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((Definition-Pattern src) (*->preserve src))))))
|
|
|
|
(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))))
|
2021-05-22 13:43:29 +00:00
|
|
|
(list
|
2021-06-08 13:26:32 +00:00
|
|
|
(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))))
|
2021-05-25 09:06:40 +00:00
|
|
|
(list
|
2021-06-08 13:26:32 +00:00
|
|
|
(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))
|
|
|
|
(struct
|
|
|
|
Definitions
|
|
|
|
(value)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
2021-05-25 09:06:40 +00:00
|
|
|
(match
|
2021-06-08 13:26:32 +00:00
|
|
|
preservable
|
2021-06-08 13:49:27 +00:00
|
|
|
((Definitions src)
|
2021-06-08 13:26:32 +00:00
|
|
|
(for/hash
|
|
|
|
(((key value) (in-dict src)))
|
2021-06-25 07:45:07 +00:00
|
|
|
(values (*->preserve key) (*->preserve value))))))))
|
2021-06-08 13:26:32 +00:00
|
|
|
(define (parse-Definitions input)
|
2021-05-22 13:43:29 +00:00
|
|
|
(match
|
|
|
|
input
|
2021-06-08 13:26:32 +00:00
|
|
|
((parse-sequence
|
|
|
|
dict?
|
|
|
|
dict->list
|
|
|
|
(cons
|
|
|
|
(and key (? symbol?))
|
|
|
|
(app parse-Definition (and value (not (== eof)))))
|
|
|
|
(cons key value)
|
|
|
|
make-immutable-hash
|
|
|
|
dest)
|
2021-06-08 13:49:27 +00:00
|
|
|
(Definitions dest))
|
2021-06-08 13:26:32 +00:00
|
|
|
(_ eof)))
|
|
|
|
(define parse-Definitions!
|
|
|
|
(parse-success-or-error 'parse-Definitions parse-Definitions))
|
|
|
|
(struct
|
|
|
|
DictionaryEntries
|
|
|
|
(value)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match
|
|
|
|
preservable
|
2021-06-08 13:49:27 +00:00
|
|
|
((DictionaryEntries src)
|
2021-06-08 13:26:32 +00:00
|
|
|
(for/hash
|
|
|
|
(((key value) (in-dict src)))
|
2021-06-25 07:45:07 +00:00
|
|
|
(values (*->preserve key) (*->preserve value))))))))
|
2021-06-08 13:26:32 +00:00
|
|
|
(define (parse-DictionaryEntries input)
|
2021-05-25 09:06:40 +00:00
|
|
|
(match
|
|
|
|
input
|
2021-06-08 13:26:32 +00:00
|
|
|
((parse-sequence
|
|
|
|
dict?
|
|
|
|
dict->list
|
|
|
|
(cons key (app parse-NamedSimplePattern (and value (not (== eof)))))
|
|
|
|
(cons key value)
|
|
|
|
make-immutable-hash
|
|
|
|
dest)
|
2021-06-08 13:49:27 +00:00
|
|
|
(DictionaryEntries dest))
|
2021-06-08 13:26:32 +00:00
|
|
|
(_ eof)))
|
|
|
|
(define parse-DictionaryEntries!
|
|
|
|
(parse-success-or-error 'parse-DictionaryEntries parse-DictionaryEntries))
|
|
|
|
(define (EmbeddedTypeName? p)
|
|
|
|
(or (EmbeddedTypeName-Ref? p) (EmbeddedTypeName-false? p)))
|
|
|
|
(struct
|
|
|
|
EmbeddedTypeName-Ref
|
|
|
|
(value)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((EmbeddedTypeName-Ref src) (*->preserve src))))))
|
|
|
|
(struct
|
|
|
|
EmbeddedTypeName-false
|
|
|
|
()
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((EmbeddedTypeName-false) '#f)))))
|
|
|
|
(define (parse-EmbeddedTypeName input)
|
2021-05-22 13:43:29 +00:00
|
|
|
(match
|
|
|
|
input
|
2021-06-08 13:26:32 +00:00
|
|
|
((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))
|
|
|
|
(struct
|
|
|
|
ModulePath
|
|
|
|
(value)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
2021-06-08 13:49:27 +00:00
|
|
|
(match
|
|
|
|
preservable
|
2021-06-25 07:45:07 +00:00
|
|
|
((ModulePath src)
|
|
|
|
(for/list ((item (in-list src))) (*->preserve item)))))))
|
2021-06-08 13:26:32 +00:00
|
|
|
(define (parse-ModulePath input)
|
2021-06-08 13:49:27 +00:00
|
|
|
(match
|
|
|
|
input
|
|
|
|
((list (and dest (? symbol?)) ...) (ModulePath dest))
|
|
|
|
(_ eof)))
|
2021-06-08 13:26:32 +00:00
|
|
|
(define parse-ModulePath!
|
|
|
|
(parse-success-or-error 'parse-ModulePath parse-ModulePath))
|
|
|
|
(struct
|
|
|
|
Modules
|
|
|
|
(value)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match
|
|
|
|
preservable
|
2021-06-08 13:49:27 +00:00
|
|
|
((Modules src)
|
2021-06-08 13:26:32 +00:00
|
|
|
(for/hash
|
|
|
|
(((key value) (in-dict src)))
|
|
|
|
(values (*->preserve key) (*->preserve value))))))))
|
|
|
|
(define (parse-Modules input)
|
2021-05-22 13:43:29 +00:00
|
|
|
(match
|
|
|
|
input
|
2021-06-08 13:26:32 +00:00
|
|
|
((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)
|
2021-06-08 13:49:27 +00:00
|
|
|
(Modules dest))
|
2021-06-08 13:26:32 +00:00
|
|
|
(_ eof)))
|
|
|
|
(define parse-Modules! (parse-success-or-error 'parse-Modules parse-Modules))
|
|
|
|
(struct
|
|
|
|
NamedAlternative
|
|
|
|
(variantLabel pattern)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match
|
|
|
|
preservable
|
|
|
|
((NamedAlternative ?variantLabel ?pattern)
|
2021-06-25 07:45:07 +00:00
|
|
|
(list (*->preserve ?variantLabel) (*->preserve ?pattern)))))))
|
2021-06-08 13:26:32 +00:00
|
|
|
(define (parse-NamedAlternative input)
|
2021-05-25 09:06:40 +00:00
|
|
|
(match
|
|
|
|
input
|
2021-06-08 13:26:32 +00:00
|
|
|
((and dest
|
|
|
|
(list
|
|
|
|
(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))
|
|
|
|
(define (NamedPattern? p)
|
|
|
|
(or (NamedPattern-named? p) (NamedPattern-anonymous? p)))
|
|
|
|
(struct
|
|
|
|
NamedPattern-named
|
|
|
|
(value)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((NamedPattern-named src) (*->preserve src))))))
|
|
|
|
(struct
|
|
|
|
NamedPattern-anonymous
|
|
|
|
(value)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((NamedPattern-anonymous src) (*->preserve src))))))
|
|
|
|
(define (parse-NamedPattern input)
|
2021-05-25 09:06:40 +00:00
|
|
|
(match
|
|
|
|
input
|
2021-06-25 08:25:26 +00:00
|
|
|
((app parse-Binding (and dest (not (== eof)))) (NamedPattern-named dest))
|
2021-06-08 13:26:32 +00:00
|
|
|
((app parse-Pattern (and dest (not (== eof))))
|
|
|
|
(NamedPattern-anonymous dest))
|
|
|
|
(_ eof)))
|
|
|
|
(define parse-NamedPattern!
|
|
|
|
(parse-success-or-error 'parse-NamedPattern parse-NamedPattern))
|
|
|
|
(define (NamedSimplePattern? p)
|
|
|
|
(or (NamedSimplePattern-named? p) (NamedSimplePattern-anonymous? p)))
|
|
|
|
(struct
|
|
|
|
NamedSimplePattern-named
|
|
|
|
(value)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((NamedSimplePattern-named src) (*->preserve src))))))
|
|
|
|
(struct
|
|
|
|
NamedSimplePattern-anonymous
|
|
|
|
(value)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match
|
|
|
|
preservable
|
|
|
|
((NamedSimplePattern-anonymous src) (*->preserve src))))))
|
|
|
|
(define (parse-NamedSimplePattern input)
|
2021-05-25 09:06:40 +00:00
|
|
|
(match
|
|
|
|
input
|
2021-06-25 08:25:26 +00:00
|
|
|
((app parse-Binding (and dest (not (== eof))))
|
2021-06-08 13:26:32 +00:00
|
|
|
(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))
|
|
|
|
(define (Pattern? p)
|
|
|
|
(or (Pattern-SimplePattern? p) (Pattern-CompoundPattern? p)))
|
|
|
|
(struct
|
|
|
|
Pattern-SimplePattern
|
|
|
|
(value)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((Pattern-SimplePattern src) (*->preserve src))))))
|
|
|
|
(struct
|
|
|
|
Pattern-CompoundPattern
|
|
|
|
(value)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((Pattern-CompoundPattern src) (*->preserve src))))))
|
|
|
|
(define (parse-Pattern input)
|
2021-05-25 09:06:40 +00:00
|
|
|
(match
|
|
|
|
input
|
2021-06-08 13:26:32 +00:00
|
|
|
((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))
|
|
|
|
(struct
|
|
|
|
Ref
|
|
|
|
(module name)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match
|
|
|
|
preservable
|
|
|
|
((Ref ?module ?name)
|
2021-06-25 07:45:07 +00:00
|
|
|
(record 'ref (list (*->preserve ?module) (*->preserve ?name))))))))
|
2021-06-08 13:26:32 +00:00
|
|
|
(define (parse-Ref input)
|
2021-05-25 09:06:40 +00:00
|
|
|
(match
|
|
|
|
input
|
2021-06-08 13:26:32 +00:00
|
|
|
((and dest
|
|
|
|
(record
|
|
|
|
'ref
|
|
|
|
(list
|
|
|
|
(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))
|
|
|
|
(struct
|
|
|
|
Schema
|
|
|
|
(definitions embeddedType version)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match
|
|
|
|
preservable
|
|
|
|
((Schema ?definitions ?embeddedType ?version)
|
|
|
|
(record
|
|
|
|
'schema
|
|
|
|
(list
|
|
|
|
(hash
|
|
|
|
'definitions
|
|
|
|
(*->preserve ?definitions)
|
|
|
|
'embeddedType
|
|
|
|
(*->preserve ?embeddedType)
|
|
|
|
'version
|
|
|
|
(*->preserve ?version)))))))))
|
|
|
|
(define (parse-Schema input)
|
2021-05-25 09:06:40 +00:00
|
|
|
(match
|
|
|
|
input
|
2021-06-08 13:26:32 +00:00
|
|
|
((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))
|
|
|
|
(define (SimplePattern? p)
|
|
|
|
(or (SimplePattern-any? p)
|
|
|
|
(SimplePattern-atom? p)
|
|
|
|
(SimplePattern-embedded? p)
|
|
|
|
(SimplePattern-lit? p)
|
|
|
|
(SimplePattern-seqof? p)
|
|
|
|
(SimplePattern-setof? p)
|
|
|
|
(SimplePattern-dictof? p)
|
|
|
|
(SimplePattern-Ref? p)))
|
|
|
|
(struct
|
|
|
|
SimplePattern-any
|
|
|
|
()
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((SimplePattern-any) 'any)))))
|
|
|
|
(struct
|
|
|
|
SimplePattern-atom
|
|
|
|
(atomKind)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match
|
|
|
|
preservable
|
|
|
|
((SimplePattern-atom ?atomKind)
|
|
|
|
(record 'atom (list (*->preserve ?atomKind))))))))
|
|
|
|
(struct
|
|
|
|
SimplePattern-embedded
|
|
|
|
(interface)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match
|
|
|
|
preservable
|
|
|
|
((SimplePattern-embedded ?interface)
|
|
|
|
(record 'embedded (list (*->preserve ?interface))))))))
|
|
|
|
(struct
|
|
|
|
SimplePattern-lit
|
|
|
|
(value)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match
|
|
|
|
preservable
|
2021-06-25 07:45:07 +00:00
|
|
|
((SimplePattern-lit ?value)
|
|
|
|
(record 'lit (list (*->preserve ?value))))))))
|
2021-06-08 13:26:32 +00:00
|
|
|
(struct
|
|
|
|
SimplePattern-seqof
|
|
|
|
(pattern)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match
|
|
|
|
preservable
|
|
|
|
((SimplePattern-seqof ?pattern)
|
|
|
|
(record 'seqof (list (*->preserve ?pattern))))))))
|
|
|
|
(struct
|
|
|
|
SimplePattern-setof
|
|
|
|
(pattern)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match
|
|
|
|
preservable
|
|
|
|
((SimplePattern-setof ?pattern)
|
|
|
|
(record 'setof (list (*->preserve ?pattern))))))))
|
|
|
|
(struct
|
|
|
|
SimplePattern-dictof
|
|
|
|
(key value)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match
|
|
|
|
preservable
|
|
|
|
((SimplePattern-dictof ?key ?value)
|
|
|
|
(record 'dictof (list (*->preserve ?key) (*->preserve ?value))))))))
|
|
|
|
(struct
|
|
|
|
SimplePattern-Ref
|
|
|
|
(value)
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable)
|
|
|
|
(match preservable ((SimplePattern-Ref src) (*->preserve src))))))
|
|
|
|
(define (parse-SimplePattern input)
|
2021-05-25 09:06:40 +00:00
|
|
|
(match
|
|
|
|
input
|
2021-06-08 13:26:32 +00:00
|
|
|
((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 (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))
|
|
|
|
((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))
|
|
|
|
(struct
|
|
|
|
Version
|
|
|
|
()
|
|
|
|
#:transparent
|
|
|
|
#:methods
|
|
|
|
gen:preservable
|
|
|
|
((define/generic *->preserve ->preserve)
|
|
|
|
(define (->preserve preservable) (match preservable ((Version) '1)))))
|
|
|
|
(define (parse-Version input)
|
|
|
|
(match input ((and dest (== '1)) (Version)) (_ eof)))
|
|
|
|
(define parse-Version!
|
|
|
|
(parse-success-or-error 'parse-Version parse-Version)))
|