(module gen-schema racket/base (provide (except-out (all-defined-out) :decode-embedded :encode-embedded) (rename-out (:decode-embedded decode-embedded:gen-schema) (:encode-embedded encode-embedded:gen-schema))) (require preserves) (require preserves-schema/methods) (require preserves-schema/support) (require racket/match) (require racket/set) (require racket/dict) (require (only-in racket/generic define/generic)) (define :decode-embedded values) (define :encode-embedded values) (define (AtomKind? p) (or (AtomKind-Boolean? p) (AtomKind-Double? p) (AtomKind-SignedInteger? p) (AtomKind-String? p) (AtomKind-ByteString? p) (AtomKind-Symbol? p))) (struct AtomKind-Boolean () #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((AtomKind-Boolean) 'Boolean))))) (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 '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)) (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)) (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)) (define (CompoundPattern? p) (or (CompoundPattern-rec? p) (CompoundPattern-tuple? p) (CompoundPattern-tuplePrefix? p) (CompoundPattern-dict? p))) (struct CompoundPattern-rec (label fields) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match 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) (match preservable ((CompoundPattern-tuple ?patterns) (record 'tuple (list (for/list ((item (in-list ?patterns))) (*->preserve item))))))))) (struct CompoundPattern-tuplePrefix (fixed variable) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((CompoundPattern-tuplePrefix ?fixed ?variable) (record 'tuplePrefix (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) (match 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 (list (app parse-NamedPattern (and ?patterns (not (== eof)))) ...)))) (CompoundPattern-tuple ?patterns)) ((and dest (record 'tuplePrefix (list (list (app parse-NamedPattern (and ?fixed (not (== eof)))) ...) (app parse-NamedSimplePattern (and ?variable (not (== eof))))))) (CompoundPattern-tuplePrefix ?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)) (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) (match 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) (match 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)))) (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)) (struct Definitions (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Definitions src) (for/hash (((key value) (in-dict src))) (values (*->preserve key) (*->preserve value)))))))) (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) (Definitions dest)) (_ 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 ((DictionaryEntries src) (for/hash (((key value) (in-dict src))) (values (*->preserve key) (*->preserve value)))))))) (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) (DictionaryEntries dest)) (_ eof))) (define parse-DictionaryEntries! (parse-success-or-error 'parse-DictionaryEntries parse-DictionaryEntries)) (define (EmbeddedTypeName? p) (or (EmbeddedTypeName-false? p) (EmbeddedTypeName-Ref? p))) (struct EmbeddedTypeName-false () #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((EmbeddedTypeName-false) '#f))))) (struct EmbeddedTypeName-Ref (value) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((EmbeddedTypeName-Ref src) (*->preserve src)))))) (define (parse-EmbeddedTypeName input) (match input ((and dest (== '#f)) (EmbeddedTypeName-false)) ((app parse-Ref (and dest (not (== eof)))) (EmbeddedTypeName-Ref dest)) (_ 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) (match preservable ((ModulePath src) (for/list ((item (in-list src))) (*->preserve item))))))) (define (parse-ModulePath input) (match input ((list (and dest (? symbol?)) ...) (ModulePath dest)) (_ eof))) (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 ((Modules src) (for/hash (((key value) (in-dict src))) (values (*->preserve key) (*->preserve value)))))))) (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) (Modules dest)) (_ 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) (list (*->preserve ?variantLabel) (*->preserve ?pattern))))))) (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-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) (match input ((app parse-Binding (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)) (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) (match input ((app parse-Binding (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)) (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) (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)) (struct Ref (module name) #:transparent #:methods gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable ((Ref ?module ?name) (record 'ref (list (*->preserve ?module) (*->preserve ?name)))))))) (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-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) (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)) (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 ((SimplePattern-lit ?value) (record 'lit (list (*->preserve ?value)))))))) (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) (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 (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)))