(module gen-schema racket/base (provide (all-defined-out)) (require preserves) (require preserves-schema/support) (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 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) (SimplePattern-embedded? p) (SimplePattern-lit? p) (SimplePattern-seqof? p) (SimplePattern-setof? p) (SimplePattern-dictof? p) (SimplePattern-Ref? p))) (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 (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 (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-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 ((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 ((Bundle $modules) (record 'bundle (list (Modules->preserves $modules)))))) (define (CompoundPattern->preserves input) (match input ((CompoundPattern-rec $label $fields) (record 'rec (list (NamedPattern->preserves $label) (NamedPattern->preserves $fields)))) ((CompoundPattern-tuple $patterns) (record 'tuple (list (for/list ((item (in-list $patterns))) (NamedPattern->preserves item))))) ((CompoundPattern-tuple* $fixed $variable) (record 'tuple* (list (for/list ((item (in-list $fixed))) (NamedPattern->preserves item)) (NamedSimplePattern->preserves $variable)))) ((CompoundPattern-dict $entries) (record 'dict (list (DictionaryEntries->preserves $entries)))))) (define (Definition->preserves input) (match input ((Definition-or $pattern0 $pattern1 $patternN) (record 'or (list (list* (NamedAlternative->preserves $pattern0) (NamedAlternative->preserves $pattern1) (for/list ((item (in-list $patternN))) (NamedAlternative->preserves item)))))) ((Definition-and $pattern0 $pattern1 $patternN) (record 'and (list (list* (NamedPattern->preserves $pattern0) (NamedPattern->preserves $pattern1) (for/list ((item (in-list $patternN))) (NamedPattern->preserves item)))))) ((Definition-Pattern src) (Pattern->preserves src)))) (define (Definitions->preserves input) (match input (src (for/hash (((key value) (in-dict src))) (values key (Definition->preserves value)))))) (define (DictionaryEntries->preserves input) (match input (src (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))))