Generic-method based unparsing; prelude to generic pattern-formation
This commit is contained in:
parent
0bcb4e64ec
commit
7acf7c5b40
|
|
@ -8,6 +8,7 @@
|
|||
|
||||
(require preserves)
|
||||
(require racket/match)
|
||||
(require (only-in racket/list append-map))
|
||||
(require (only-in racket/string string-join))
|
||||
(require (only-in racket/format ~a))
|
||||
(require (only-in racket/syntax format-symbol))
|
||||
|
|
@ -29,8 +30,15 @@
|
|||
relative-output-path)
|
||||
#:transparent)
|
||||
|
||||
(define (struct-stx name-pieces field-names)
|
||||
`(struct ,(string->symbol (string-join (map ~a name-pieces) "-")) ,field-names #:prefab))
|
||||
(define (struct-stx name field-names more)
|
||||
`(struct ,name ,field-names #:transparent
|
||||
,@more))
|
||||
|
||||
(define (ty->struct-field-names ty)
|
||||
(match ty
|
||||
[(ty-record fields) (map ty-field-name fields)] ;; not escaped here
|
||||
[(ty-unit) '()]
|
||||
[_ '(value)]))
|
||||
|
||||
(define (fold-Schema-definitions kc kn schema)
|
||||
(foldr (lambda (entry acc) (kc (car entry) (cdr entry) acc))
|
||||
|
|
@ -91,40 +99,112 @@
|
|||
[(EmbeddedTypeName-false) `((define :decode-embedded values)
|
||||
(define :encode-embedded values))]
|
||||
[(EmbeddedTypeName-Ref r) `((define :decode-embedded ,(Ref-parser!-name r))
|
||||
(define :encode-embedded ,(Ref-unparser-name r)))]))
|
||||
(define :encode-embedded ->preserve))]))
|
||||
|
||||
(define (struct-defs schema)
|
||||
(fold-Schema-definitions
|
||||
(lambda (name def acc)
|
||||
(match (definition-ty def)
|
||||
[(ty-union variants)
|
||||
(for/fold [(acc (cons `(define (,(format-symbol "~a?" name) p)
|
||||
|
||||
(define (parse!-definition name)
|
||||
`(define ,(format-symbol "parse-~a!" name)
|
||||
(parse-success-or-error ',(format-symbol "parse-~a" name)
|
||||
,(format-symbol "parse-~a" name))))
|
||||
|
||||
(define ((compile-definition plugins) name def acc)
|
||||
(define ty (definition-ty def))
|
||||
(match def
|
||||
|
||||
[(? Definition-or?)
|
||||
(define variants (ty-union-variants ty))
|
||||
|
||||
`[ (define (,(format-symbol "~a?" name) p)
|
||||
(or ,@(for/list [(variant (in-list variants))]
|
||||
`(,(format-symbol "~a-~a?" name (car variant)) p))))
|
||||
acc))]
|
||||
[(variant (in-list variants))]
|
||||
(match-define (list variant-name variant-ty) variant)
|
||||
(match variant-ty
|
||||
[(ty-record fields)
|
||||
(cons (struct-stx (list name variant-name) (map ty-field-name fields)) acc)]
|
||||
[(ty-unit)
|
||||
(cons (struct-stx (list name variant-name) '()) acc)]
|
||||
[_
|
||||
(cons (struct-stx (list name variant-name) '(value)) acc)]))]
|
||||
[(ty-unit)
|
||||
(cons (struct-stx (list name) '()) acc)]
|
||||
[(ty-record fields)
|
||||
(cons (struct-stx (list name) (map ty-field-name fields)) acc)]
|
||||
[_
|
||||
acc]))
|
||||
'()
|
||||
schema))
|
||||
`(,(format-symbol "~a-~a?" name (ty-variant-name variant)) p))))
|
||||
|
||||
(define (parser-defs schema)
|
||||
(map-Schema-definitions definition-parsers schema))
|
||||
,@(for/list [(variant (in-list variants))]
|
||||
(match-define (ty-variant variant-name variant-ty variant-pat) variant)
|
||||
(define full-name (format-symbol "~a-~a" name variant-name))
|
||||
(struct-stx full-name
|
||||
(ty->struct-field-names variant-ty)
|
||||
`[ #:methods gen:preservable
|
||||
[(define/generic *->preserve ->preserve)
|
||||
(define (->preserve preservable)
|
||||
(match preservable
|
||||
[,(deconstruct full-name #t variant-ty)
|
||||
,(pattern->unparser variant-pat 'src)]))]
|
||||
|
||||
(define (unparser-defs schema)
|
||||
(map-Schema-definitions definition-unparser schema))
|
||||
]))
|
||||
|
||||
(define (,(format-symbol "parse-~a" name) input)
|
||||
(match input
|
||||
,@(for/list [(variant (in-list variants))]
|
||||
(match-define (ty-variant variant-name variant-ty variant-pat) variant)
|
||||
`[,(pattern->match-pattern variant-pat 'dest)
|
||||
,(construct (format-symbol "~a-~a" name variant-name) #t variant-ty)])
|
||||
[_ eof]))
|
||||
,(parse!-definition name)
|
||||
|
||||
,@acc ]]
|
||||
|
||||
[(Definition-and p0 p1 pN)
|
||||
(define facets (list* p0 p1 pN))
|
||||
|
||||
`[ ,(struct-stx name
|
||||
(ty->struct-field-names ty)
|
||||
`[ #:methods gen:preservable
|
||||
[(define/generic *->preserve ->preserve)
|
||||
(define (->preserve preservable)
|
||||
(match preservable
|
||||
[,(deconstruct name #f ty)
|
||||
(merge-preserves
|
||||
(lambda (a b) (if (equal? a b)
|
||||
a
|
||||
(error 'merge-preserves "Cannot merge")))
|
||||
,@(append-map
|
||||
(lambda (named-pat)
|
||||
(match named-pat
|
||||
[(NamedPattern-anonymous (Pattern-SimplePattern _)) '()]
|
||||
[_ (list (pattern->unparser named-pat 'src))]))
|
||||
facets))]))]
|
||||
])
|
||||
|
||||
(define (,(format-symbol "parse-~a" name) input)
|
||||
(match input
|
||||
[(and ,@(for/list [(named-pat facets)] (pattern->match-pattern named-pat '_)))
|
||||
,(construct name #f ty)]
|
||||
[_ eof]))
|
||||
,(parse!-definition name)
|
||||
|
||||
,@acc ]]
|
||||
|
||||
[(Definition-Pattern pattern)
|
||||
`[ ,(struct-stx name
|
||||
(ty->struct-field-names ty)
|
||||
`[ #:methods gen:preservable
|
||||
[(define/generic *->preserve ->preserve)
|
||||
(define (->preserve preservable)
|
||||
(match preservable
|
||||
[,(deconstruct name #f ty)
|
||||
,(pattern->unparser pattern 'src)]))]
|
||||
])
|
||||
|
||||
(define (,(format-symbol "parse-~a" name) input)
|
||||
(match input
|
||||
[,(pattern->match-pattern pattern 'dest)
|
||||
,(construct name #f ty)]
|
||||
[_ eof]))
|
||||
,(parse!-definition name)
|
||||
|
||||
,@acc ]]))
|
||||
|
||||
(define (deconstruct name wrap? ty)
|
||||
(match ty
|
||||
[(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
|
||||
[(ty-unit) `(,name)]
|
||||
[_ (if wrap? `(,name src) 'src)]))
|
||||
|
||||
(define (construct name wrap? ty)
|
||||
(match ty
|
||||
[(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
|
||||
[(ty-unit) `(,name)]
|
||||
[_ (if wrap? `(,name dest) 'dest)]))
|
||||
|
||||
(define (schema->module-stx name lookup-module-path schema
|
||||
#:translation-paths [translation-paths #f]
|
||||
|
|
@ -136,17 +216,18 @@
|
|||
(provide (except-out (all-defined-out) :decode-embedded :encode-embedded)
|
||||
(rename-out [:decode-embedded ,(format-symbol "decode-embedded:~a" name)]
|
||||
[:encode-embedded ,(format-symbol "encode-embedded:~a" name)]))
|
||||
,@(module-imports name schema lookup-module-path translation-paths)
|
||||
,@(embedded-defs schema)
|
||||
|
||||
(require preserves)
|
||||
(require preserves-schema/methods)
|
||||
(require preserves-schema/support)
|
||||
(require racket/match)
|
||||
(require racket/set)
|
||||
(require racket/dict)
|
||||
,@(struct-defs schema)
|
||||
,@(parser-defs schema)
|
||||
,@(unparser-defs schema)
|
||||
,@(for/list [(plugin (in-list plugins))] (plugin schema options))
|
||||
(require (only-in racket/generic define/generic))
|
||||
,@(module-imports name schema lookup-module-path translation-paths)
|
||||
,@(embedded-defs schema)
|
||||
,@(fold-Schema-definitions (compile-definition plugins) '() schema)
|
||||
,@(for/list [(plugin (in-list plugins))] ((plugin 'schema) schema options))
|
||||
))
|
||||
|
||||
(module+ main
|
||||
|
|
|
|||
|
|
@ -3,20 +3,15 @@
|
|||
(rename-out
|
||||
(:decode-embedded decode-embedded:gen-schema)
|
||||
(:encode-embedded encode-embedded:gen-schema)))
|
||||
(define :decode-embedded values)
|
||||
(define :encode-embedded values)
|
||||
(require preserves)
|
||||
(require preserves-schema/methods)
|
||||
(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)
|
||||
(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)
|
||||
|
|
@ -25,60 +20,69 @@
|
|||
(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 (interface) #: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)))
|
||||
(struct Version () #:prefab)
|
||||
(begin
|
||||
(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
|
||||
|
|
@ -91,8 +95,18 @@
|
|||
((and dest 'Symbol) (AtomKind-Symbol))
|
||||
(_ eof)))
|
||||
(define parse-AtomKind!
|
||||
(parse-success-or-error 'parse-AtomKind parse-AtomKind)))
|
||||
(begin
|
||||
(parse-success-or-error 'parse-AtomKind parse-AtomKind))
|
||||
(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
|
||||
|
|
@ -102,8 +116,67 @@
|
|||
(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-Bundle! (parse-success-or-error 'parse-Bundle parse-Bundle))
|
||||
(define (CompoundPattern? p)
|
||||
(or (CompoundPattern-rec? p)
|
||||
(CompoundPattern-tuple? p)
|
||||
(CompoundPattern-tuple*? 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-tuple*
|
||||
(fixed variable)
|
||||
#:transparent
|
||||
#:methods
|
||||
gen:preservable
|
||||
((define/generic *->preserve ->preserve)
|
||||
(define (->preserve preservable)
|
||||
(match
|
||||
preservable
|
||||
((CompoundPattern-tuple* ?fixed ?variable)
|
||||
(record
|
||||
'tuple*
|
||||
(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
|
||||
|
|
@ -137,8 +210,54 @@
|
|||
(CompoundPattern-dict ?entries))
|
||||
(_ eof)))
|
||||
(define parse-CompoundPattern!
|
||||
(parse-success-or-error 'parse-CompoundPattern parse-CompoundPattern)))
|
||||
(begin
|
||||
(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
|
||||
|
|
@ -164,12 +283,24 @@
|
|||
(app parse-NamedPattern (and ?patternN (not (== eof))))
|
||||
...)))))
|
||||
(Definition-and ?pattern0 ?pattern1 ?patternN))
|
||||
((app parse-Pattern (and dest (not (== eof))))
|
||||
(Definition-Pattern dest))
|
||||
((app parse-Pattern (and dest (not (== eof)))) (Definition-Pattern dest))
|
||||
(_ eof)))
|
||||
(define parse-Definition!
|
||||
(parse-success-or-error 'parse-Definition parse-Definition)))
|
||||
(begin
|
||||
(parse-success-or-error 'parse-Definition parse-Definition))
|
||||
(struct
|
||||
Definitions
|
||||
(value)
|
||||
#:transparent
|
||||
#:methods
|
||||
gen:preservable
|
||||
((define/generic *->preserve ->preserve)
|
||||
(define (->preserve preservable)
|
||||
(match
|
||||
preservable
|
||||
(src
|
||||
(for/hash
|
||||
(((key value) (in-dict src)))
|
||||
(values key (*->preserve value))))))))
|
||||
(define (parse-Definitions input)
|
||||
(match
|
||||
input
|
||||
|
|
@ -185,8 +316,21 @@
|
|||
dest)
|
||||
(_ eof)))
|
||||
(define parse-Definitions!
|
||||
(parse-success-or-error 'parse-Definitions parse-Definitions)))
|
||||
(begin
|
||||
(parse-success-or-error 'parse-Definitions parse-Definitions))
|
||||
(struct
|
||||
DictionaryEntries
|
||||
(value)
|
||||
#:transparent
|
||||
#:methods
|
||||
gen:preservable
|
||||
((define/generic *->preserve ->preserve)
|
||||
(define (->preserve preservable)
|
||||
(match
|
||||
preservable
|
||||
(src
|
||||
(for/hash
|
||||
(((key value) (in-dict src)))
|
||||
(values key (*->preserve value))))))))
|
||||
(define (parse-DictionaryEntries input)
|
||||
(match
|
||||
input
|
||||
|
|
@ -200,10 +344,27 @@
|
|||
dest)
|
||||
(_ eof)))
|
||||
(define parse-DictionaryEntries!
|
||||
(parse-success-or-error
|
||||
'parse-DictionaryEntries
|
||||
parse-DictionaryEntries)))
|
||||
(begin
|
||||
(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
|
||||
|
|
@ -211,13 +372,34 @@
|
|||
((and dest (== '#f)) (EmbeddedTypeName-false))
|
||||
(_ eof)))
|
||||
(define parse-EmbeddedTypeName!
|
||||
(parse-success-or-error 'parse-EmbeddedTypeName parse-EmbeddedTypeName)))
|
||||
(begin
|
||||
(parse-success-or-error 'parse-EmbeddedTypeName parse-EmbeddedTypeName))
|
||||
(struct
|
||||
ModulePath
|
||||
(value)
|
||||
#:transparent
|
||||
#:methods
|
||||
gen:preservable
|
||||
((define/generic *->preserve ->preserve)
|
||||
(define (->preserve preservable)
|
||||
(match preservable (src (for/list ((item (in-list src))) item))))))
|
||||
(define (parse-ModulePath input)
|
||||
(match input ((list (and dest (? symbol?)) ...) dest) (_ eof)))
|
||||
(define parse-ModulePath!
|
||||
(parse-success-or-error 'parse-ModulePath parse-ModulePath)))
|
||||
(begin
|
||||
(parse-success-or-error 'parse-ModulePath parse-ModulePath))
|
||||
(struct
|
||||
Modules
|
||||
(value)
|
||||
#:transparent
|
||||
#:methods
|
||||
gen:preservable
|
||||
((define/generic *->preserve ->preserve)
|
||||
(define (->preserve preservable)
|
||||
(match
|
||||
preservable
|
||||
(src
|
||||
(for/hash
|
||||
(((key value) (in-dict src)))
|
||||
(values (*->preserve key) (*->preserve value))))))))
|
||||
(define (parse-Modules input)
|
||||
(match
|
||||
input
|
||||
|
|
@ -232,9 +414,19 @@
|
|||
dest)
|
||||
dest)
|
||||
(_ eof)))
|
||||
(define parse-Modules!
|
||||
(parse-success-or-error 'parse-Modules parse-Modules)))
|
||||
(begin
|
||||
(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 ?variantLabel (*->preserve ?pattern)))))))
|
||||
(define (parse-NamedAlternative input)
|
||||
(match
|
||||
input
|
||||
|
|
@ -245,8 +437,27 @@
|
|||
(NamedAlternative ?variantLabel ?pattern))
|
||||
(_ eof)))
|
||||
(define parse-NamedAlternative!
|
||||
(parse-success-or-error 'parse-NamedAlternative parse-NamedAlternative)))
|
||||
(begin
|
||||
(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
|
||||
|
|
@ -256,8 +467,29 @@
|
|||
(NamedPattern-anonymous dest))
|
||||
(_ eof)))
|
||||
(define parse-NamedPattern!
|
||||
(parse-success-or-error 'parse-NamedPattern parse-NamedPattern)))
|
||||
(begin
|
||||
(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
|
||||
|
|
@ -269,8 +501,19 @@
|
|||
(define parse-NamedSimplePattern!
|
||||
(parse-success-or-error
|
||||
'parse-NamedSimplePattern
|
||||
parse-NamedSimplePattern)))
|
||||
(begin
|
||||
parse-NamedSimplePattern))
|
||||
(struct
|
||||
NamedSimplePattern_
|
||||
(name pattern)
|
||||
#:transparent
|
||||
#:methods
|
||||
gen:preservable
|
||||
((define/generic *->preserve ->preserve)
|
||||
(define (->preserve preservable)
|
||||
(match
|
||||
preservable
|
||||
((NamedSimplePattern_ ?name ?pattern)
|
||||
(record 'named (list ?name (*->preserve ?pattern))))))))
|
||||
(define (parse-NamedSimplePattern_ input)
|
||||
(match
|
||||
input
|
||||
|
|
@ -285,8 +528,27 @@
|
|||
(define parse-NamedSimplePattern_!
|
||||
(parse-success-or-error
|
||||
'parse-NamedSimplePattern_
|
||||
parse-NamedSimplePattern_)))
|
||||
(begin
|
||||
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
|
||||
|
|
@ -295,9 +557,19 @@
|
|||
((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-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) ?name)))))))
|
||||
(define (parse-Ref input)
|
||||
(match
|
||||
input
|
||||
|
|
@ -309,8 +581,28 @@
|
|||
(and ?name (? symbol?)))))
|
||||
(Ref ?module ?name))
|
||||
(_ eof)))
|
||||
(define parse-Ref! (parse-success-or-error 'parse-Ref parse-Ref)))
|
||||
(begin
|
||||
(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
|
||||
|
|
@ -322,16 +614,111 @@
|
|||
('definitions
|
||||
(app parse-Definitions (and ?definitions (not (== eof)))))
|
||||
('embeddedType
|
||||
(app
|
||||
parse-EmbeddedTypeName
|
||||
(and ?embeddedType (not (== eof)))))
|
||||
(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-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 ?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
|
||||
|
|
@ -344,8 +731,7 @@
|
|||
((and dest
|
||||
(record
|
||||
'embedded
|
||||
(list
|
||||
(app parse-SimplePattern (and ?interface (not (== eof)))))))
|
||||
(list (app parse-SimplePattern (and ?interface (not (== eof)))))))
|
||||
(SimplePattern-embedded ?interface))
|
||||
((and dest (record 'lit (list ?value))) (SimplePattern-lit ?value))
|
||||
((and dest
|
||||
|
|
@ -368,165 +754,16 @@
|
|||
((app parse-Ref (and dest (not (== eof)))) (SimplePattern-Ref dest))
|
||||
(_ eof)))
|
||||
(define parse-SimplePattern!
|
||||
(parse-success-or-error 'parse-SimplePattern parse-SimplePattern)))
|
||||
(begin
|
||||
(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)))
|
||||
(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 ?interface)
|
||||
(record 'embedded (list (SimplePattern->preserves ?interface))))
|
||||
((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 ((Version) '1))))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,44 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide gen:preservable
|
||||
preservable?
|
||||
->preserve
|
||||
preservable/c)
|
||||
|
||||
(require preserves)
|
||||
(require racket/generic)
|
||||
(require racket/set)
|
||||
(require racket/dict)
|
||||
|
||||
(define-generics preservable
|
||||
(->preserve preservable)
|
||||
#:fast-defaults ([boolean? (define (->preserve preservable) preservable)]
|
||||
[number? (define (->preserve preservable) preservable)]
|
||||
[string? (define (->preserve preservable) preservable)]
|
||||
[bytes? (define (->preserve preservable) preservable)]
|
||||
[symbol? (define (->preserve preservable) preservable)]
|
||||
[null? (define (->preserve preservable) preservable)]
|
||||
[pair?
|
||||
(define/generic *->preserve ->preserve)
|
||||
(define (->preserve preservable) (map *->preserve preservable))]
|
||||
[hash?
|
||||
(define/generic *->preserve ->preserve)
|
||||
(define (->preserve preservable)
|
||||
(for/hash [((k v) (in-hash preservable))]
|
||||
(values (*->preserve k) (*->preserve v))))])
|
||||
#:defaults ([float? (define (->preserve preservable) preservable)]
|
||||
[record?
|
||||
(define/generic *->preserve ->preserve)
|
||||
(define (->preserve preservable)
|
||||
(record (*->preserve (record-label preservable))
|
||||
(map *->preserve (record-fields preservable))))]
|
||||
[set?
|
||||
(define/generic *->preserve ->preserve)
|
||||
(define (->preserve preservable)
|
||||
(for/set [(v (in-set preservable))]
|
||||
(*->preserve v)))]
|
||||
[dict?
|
||||
(define/generic *->preserve ->preserve)
|
||||
(define (->preserve preservable)
|
||||
(for/hash [((k v) (in-dict preservable))]
|
||||
(values (*->preserve k) (*->preserve v))))]))
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide definition-parsers
|
||||
(provide pattern->match-pattern
|
||||
Ref-parser-name
|
||||
Ref-parser!-name)
|
||||
|
||||
|
|
@ -11,40 +11,6 @@
|
|||
(require "type.rkt")
|
||||
(require "gen/schema.rkt")
|
||||
|
||||
(define (definition-parsers name def)
|
||||
(define ty (definition-ty def))
|
||||
`(begin
|
||||
(define (,(format-symbol "parse-~a" name) input)
|
||||
,(match def
|
||||
[(Definition-or p0 p1 pN)
|
||||
`(match input
|
||||
,@(for/list [(named-alt (in-list (list* p0 p1 pN)))
|
||||
(alt-ty (in-list (map cadr (ty-union-variants ty))))]
|
||||
(match-define (NamedAlternative variant-label-str pattern) named-alt)
|
||||
`[,(pattern->match-pattern pattern 'dest)
|
||||
,(construct (format-symbol "~a-~a" name variant-label-str) #t alt-ty)])
|
||||
[_ eof])]
|
||||
[(Definition-and p0 p1 pN)
|
||||
`(match input
|
||||
[(and ,@(for/list [(named-pat (list* p0 p1 pN))]
|
||||
(pattern->match-pattern named-pat '_)))
|
||||
,(construct name #f ty)]
|
||||
[_ eof])]
|
||||
[(Definition-Pattern pattern)
|
||||
`(match input
|
||||
[,(pattern->match-pattern pattern 'dest)
|
||||
,(construct name #f ty)]
|
||||
[_ eof])]))
|
||||
(define ,(format-symbol "parse-~a!" name)
|
||||
(parse-success-or-error ',(format-symbol "parse-~a" name)
|
||||
,(format-symbol "parse-~a" name)))))
|
||||
|
||||
(define (construct name wrap? ty)
|
||||
(match ty
|
||||
[(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
|
||||
[(ty-unit) `(,name)]
|
||||
[_ (if wrap? `(,name dest) 'dest)]))
|
||||
|
||||
(define (maybe-dest dest-pat-stx pat)
|
||||
(match dest-pat-stx
|
||||
['_ pat]
|
||||
|
|
|
|||
|
|
@ -212,5 +212,6 @@
|
|||
|
||||
(module+ main
|
||||
(require preserves)
|
||||
(require "methods.rkt")
|
||||
(define expected (car (file->preserves "../../../../schema/schema.bin")))
|
||||
(equal? expected (Schema->preserves (file->schema "../../../../schema/schema.prs"))))
|
||||
(equal? expected (->preserve (file->schema "../../../../schema/schema.prs"))))
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
(struct-out ty-set)
|
||||
(struct-out ty-dictionary)
|
||||
|
||||
(struct-out ty-variant)
|
||||
(struct-out ty-field)
|
||||
|
||||
definition-ty
|
||||
|
|
@ -32,14 +33,16 @@
|
|||
(struct ty-set (type) #:transparent)
|
||||
(struct ty-dictionary (key-type value-type) #:transparent)
|
||||
|
||||
(struct ty-variant (name type pattern) #:transparent)
|
||||
(struct ty-field (name type pattern) #:transparent)
|
||||
|
||||
(define (definition-ty d)
|
||||
(match d
|
||||
[(Definition-or p0 p1 pN)
|
||||
(ty-union (map (match-lambda
|
||||
[(NamedAlternative variant-label-str pattern)
|
||||
(list (string->symbol variant-label-str) (pattern-ty pattern))])
|
||||
(ty-union (map (match-lambda [(NamedAlternative variant-label-str pattern)
|
||||
(ty-variant (string->symbol variant-label-str)
|
||||
(pattern-ty pattern)
|
||||
pattern)])
|
||||
(list* p0 p1 pN)))]
|
||||
[(Definition-and p0 p1 pN) (product-ty (list* p0 p1 pN))]
|
||||
[(Definition-Pattern pattern) (pattern-ty pattern)]))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide definition-unparser
|
||||
Ref-unparser-name)
|
||||
(provide pattern->unparser)
|
||||
|
||||
(require preserves)
|
||||
(require racket/match)
|
||||
|
|
@ -11,38 +10,6 @@
|
|||
(require "type.rkt")
|
||||
(require "gen/schema.rkt")
|
||||
|
||||
(define (definition-unparser name def)
|
||||
(define ty (definition-ty def))
|
||||
`(define (,(format-symbol "~a->preserves" name) input)
|
||||
,(match def
|
||||
[(Definition-or p0 p1 pN)
|
||||
`(match input
|
||||
,@(for/list [(named-alt (in-list (list* p0 p1 pN)))
|
||||
(alt-ty (in-list (map cadr (ty-union-variants ty))))]
|
||||
(match-define (NamedAlternative variant-label-str pattern) named-alt)
|
||||
`[,(deconstruct (format-symbol "~a-~a" name variant-label-str) #t alt-ty)
|
||||
,(pattern->unparser pattern 'src)]))]
|
||||
[(Definition-and p0 p1 pN)
|
||||
`(match input
|
||||
[,(deconstruct name #f ty)
|
||||
(merge-preserves
|
||||
(lambda (a b) (if (equal? a b) a (error 'merge-preserves "Cannot merge")))
|
||||
,@(append-map (lambda (named-pat)
|
||||
(match named-pat
|
||||
[(NamedPattern-anonymous (Pattern-SimplePattern _)) '()]
|
||||
[_ (list (pattern->unparser named-pat 'src))]))
|
||||
(list* p0 p1 pN)))])]
|
||||
[(Definition-Pattern pattern)
|
||||
`(match input
|
||||
[,(deconstruct name #f ty)
|
||||
,(pattern->unparser pattern 'src)])])))
|
||||
|
||||
(define (deconstruct name wrap? ty)
|
||||
(match ty
|
||||
[(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
|
||||
[(ty-unit) `(,name)]
|
||||
[_ (if wrap? `(,name src) 'src)]))
|
||||
|
||||
(define (pattern->unparser pattern src-stx)
|
||||
(match (unwrap pattern)
|
||||
[(NamedSimplePattern_ n p) (pattern->unparser p (escape n))]
|
||||
|
|
@ -59,7 +26,7 @@
|
|||
(values ,(pattern->unparser key-pat 'key)
|
||||
,(pattern->unparser value-pat 'value)))]
|
||||
[(SimplePattern-Ref r)
|
||||
`(,(Ref-unparser-name r) ,src-stx)]
|
||||
`(*->preserve ,src-stx)]
|
||||
[(CompoundPattern-rec label-pat fields-pat)
|
||||
`(record ,(pattern->unparser label-pat src-stx) ,(pattern->unparser fields-pat src-stx))]
|
||||
[(CompoundPattern-tuple named-pats)
|
||||
|
|
@ -72,7 +39,3 @@
|
|||
(list `',(car entry)
|
||||
(pattern->unparser (cdr entry) src-stx)))
|
||||
(sorted-dict-entries entries)))]))
|
||||
|
||||
(define (Ref-unparser-name r)
|
||||
(match-define (Ref module-path name) r)
|
||||
(format-symbol "~a~a->preserves" (module-path-prefix module-path) name))
|
||||
|
|
|
|||
Loading…
Reference in New Issue