From 7acf7c5b4012502aa7edd51ab8a1e60b29d62fc3 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 8 Jun 2021 15:26:32 +0200 Subject: [PATCH] Generic-method based unparsing; prelude to generic pattern-formation --- .../preserves/preserves-schema/compiler.rkt | 159 ++- .../preserves/preserves-schema/gen/schema.rkt | 1201 ++++++++++------- .../preserves/preserves-schema/methods.rkt | 44 + .../preserves/preserves-schema/parser.rkt | 36 +- .../preserves/preserves-schema/reader.rkt | 3 +- .../preserves/preserves-schema/type.rkt | 9 +- .../preserves/preserves-schema/unparser.rkt | 41 +- 7 files changed, 894 insertions(+), 599 deletions(-) create mode 100644 implementations/racket/preserves/preserves-schema/methods.rkt diff --git a/implementations/racket/preserves/preserves-schema/compiler.rkt b/implementations/racket/preserves/preserves-schema/compiler.rkt index 696f9e7..618f40f 100644 --- a/implementations/racket/preserves/preserves-schema/compiler.rkt +++ b/implementations/racket/preserves/preserves-schema/compiler.rkt @@ -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) - (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)) -(define (parser-defs schema) - (map-Schema-definitions definition-parsers schema)) +(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 (unparser-defs schema) - (map-Schema-definitions definition-unparser schema)) +(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 (ty-variant-name variant)) p)))) + + ,@(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 (,(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 diff --git a/implementations/racket/preserves/preserves-schema/gen/schema.rkt b/implementations/racket/preserves/preserves-schema/gen/schema.rkt index d311e6f..2040d22 100644 --- a/implementations/racket/preserves/preserves-schema/gen/schema.rkt +++ b/implementations/racket/preserves/preserves-schema/gen/schema.rkt @@ -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,49 +20,607 @@ (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) + (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 + 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-tuple*? p) (CompoundPattern-dict? p))) - (struct Definition-Pattern (value) #:prefab) - (struct Definition-and (pattern0 pattern1 patternN) #:prefab) - (struct Definition-or (pattern0 pattern1 patternN) #:prefab) + (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 + ((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)) (define (Definition? p) (or (Definition-or? p) (Definition-and? p) (Definition-Pattern? p))) - (struct EmbeddedTypeName-false () #:prefab) - (struct EmbeddedTypeName-Ref (value) #:prefab) + (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 + (src + (for/hash + (((key value) (in-dict src))) + (values 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) + 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 + (src + (for/hash + (((key value) (in-dict src))) + (values 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) + dest) + (_ eof))) + (define parse-DictionaryEntries! + (parse-success-or-error 'parse-DictionaryEntries parse-DictionaryEntries)) (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) + (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 (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)) + (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 + ((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)) + (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 + ((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 NamedSimplePattern-anonymous (value) #:prefab) - (struct NamedSimplePattern-named (value) #:prefab) + (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-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)) (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) + (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-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)) + (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 + ((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_)) (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) + (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) ?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) @@ -77,456 +630,140 @@ (SimplePattern-setof? p) (SimplePattern-dictof? p) (SimplePattern-Ref? p))) - (struct Version () #:prefab) - (begin - (define (parse-AtomKind input) + (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 - 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) + 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 - 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) + 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 - 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) + preservable + ((SimplePattern-lit ?value) (record 'lit (list ?value))))))) + (struct + SimplePattern-seqof + (pattern) + #:transparent + #:methods + gen:preservable + ((define/generic *->preserve ->preserve) + (define (->preserve preservable) (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) + 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 - 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) + 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 - 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 - (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))) - (begin - (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) + 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 - ((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)))) + ((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))) diff --git a/implementations/racket/preserves/preserves-schema/methods.rkt b/implementations/racket/preserves/preserves-schema/methods.rkt new file mode 100644 index 0000000..d84b52f --- /dev/null +++ b/implementations/racket/preserves/preserves-schema/methods.rkt @@ -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))))])) diff --git a/implementations/racket/preserves/preserves-schema/parser.rkt b/implementations/racket/preserves/preserves-schema/parser.rkt index f58ae88..11efd92 100644 --- a/implementations/racket/preserves/preserves-schema/parser.rkt +++ b/implementations/racket/preserves/preserves-schema/parser.rkt @@ -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] diff --git a/implementations/racket/preserves/preserves-schema/reader.rkt b/implementations/racket/preserves/preserves-schema/reader.rkt index 7eb6653..7b35440 100644 --- a/implementations/racket/preserves/preserves-schema/reader.rkt +++ b/implementations/racket/preserves/preserves-schema/reader.rkt @@ -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")))) diff --git a/implementations/racket/preserves/preserves-schema/type.rkt b/implementations/racket/preserves/preserves-schema/type.rkt index 65a0f0a..a8b018a 100644 --- a/implementations/racket/preserves/preserves-schema/type.rkt +++ b/implementations/racket/preserves/preserves-schema/type.rkt @@ -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)])) diff --git a/implementations/racket/preserves/preserves-schema/unparser.rkt b/implementations/racket/preserves/preserves-schema/unparser.rkt index 71c4c1f..825aa58 100644 --- a/implementations/racket/preserves/preserves-schema/unparser.rkt +++ b/implementations/racket/preserves/preserves-schema/unparser.rkt @@ -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))