syndicate-lang
/
preserves
mirror of https://gitlab.com/preserves/preserves.git
1
0
Fork 1
Code Releases Activity
preserves/implementations/racket/preserves/preserves-schema/gen/schema.rkt

773 lines
22 KiB
Racket
Raw Blame History

(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-Float? 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-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))
(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-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)
(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))
(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)))
View Git Blame Copy Permalink