From 27002dfe7ff71a899bc3e3ee34144f8693d29728 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 8 Jun 2021 15:49:27 +0200 Subject: [PATCH] Always use wrapper struct --- .../preserves/preserves-schema/checker.rkt | 4 +-- .../preserves/preserves-schema/compiler.rkt | 26 +++++++++---------- .../preserves/preserves-schema/gen/schema.rkt | 21 +++++++++------ .../preserves/preserves-schema/parser.rkt | 6 ++--- .../preserves/preserves-schema/reader.rkt | 17 ++++++------ .../preserves/preserves-schema/type.rkt | 2 +- .../preserves/preserves-schema/unparser.rkt | 2 +- 7 files changed, 42 insertions(+), 36 deletions(-) diff --git a/implementations/racket/preserves/preserves-schema/checker.rkt b/implementations/racket/preserves/preserves-schema/checker.rkt index ea7ff47..e14a0ae 100644 --- a/implementations/racket/preserves/preserves-schema/checker.rkt +++ b/implementations/racket/preserves/preserves-schema/checker.rkt @@ -36,7 +36,7 @@ [(CompoundPattern-tuple* ps v) (for [(p (in-list ps)) (i (in-naturals))] (check-named-pattern (cons i context) scope p)) (check-named-pattern (cons "tail" context) scope v)] - [(CompoundPattern-dict entries) + [(CompoundPattern-dict (DictionaryEntries entries)) (for [(entry (in-list (sorted-dict-entries entries)))] (check-named-pattern (cons (car entry) context) scope (cdr entry)))])) @@ -47,7 +47,7 @@ (check-pattern (cons n context) scope p #t)] [p (check-pattern context scope p #f)])) - (for [((name def) (in-hash (Schema-definitions schema)))] + (for [((name def) (in-hash (Definitions-value (Schema-definitions schema))))] (define context (list name)) (match def [(Definition-or p0 p1 pN) diff --git a/implementations/racket/preserves/preserves-schema/compiler.rkt b/implementations/racket/preserves/preserves-schema/compiler.rkt index 618f40f..f017941 100644 --- a/implementations/racket/preserves/preserves-schema/compiler.rkt +++ b/implementations/racket/preserves/preserves-schema/compiler.rkt @@ -43,7 +43,7 @@ (define (fold-Schema-definitions kc kn schema) (foldr (lambda (entry acc) (kc (car entry) (cdr entry) acc)) kn - (sorted-dict-entries (Schema-definitions schema)))) + (sorted-dict-entries (Definitions-value (Schema-definitions schema))))) (define (map-Schema-definitions proc schema) (fold-Schema-definitions (lambda (n p acc) (cons (proc n p) acc)) '() schema)) @@ -51,7 +51,7 @@ (define (module-imports name schema lookup-module-path translation-paths) (define imports (make-hash)) (define (import-ref! r) - (match-define (Ref module-path _name) r) + (match-define (Ref (ModulePath module-path) _name) r) (when (not (null? module-path)) (hash-set! imports module-path #t))) (define (walk x) @@ -76,7 +76,7 @@ [(CompoundPattern-tuple* fixed-named-pats variable-named-pat) (for-each walk fixed-named-pats) (walk variable-named-pat)] - [(CompoundPattern-dict entries) + [(CompoundPattern-dict (DictionaryEntries entries)) (for-each walk (map cdr (sorted-dict-entries entries)))] [x (error 'module-imports "Unimplemented: ~v" x)])) (match (Schema-embeddedType schema) @@ -127,7 +127,7 @@ [(define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable - [,(deconstruct full-name #t variant-ty) + [,(deconstruct full-name variant-ty) ,(pattern->unparser variant-pat 'src)]))] ])) @@ -137,7 +137,7 @@ ,@(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)]) + ,(construct (format-symbol "~a-~a" name variant-name) variant-ty)]) [_ eof])) ,(parse!-definition name) @@ -152,7 +152,7 @@ [(define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable - [,(deconstruct name #f ty) + [,(deconstruct name ty) (merge-preserves (lambda (a b) (if (equal? a b) a @@ -168,7 +168,7 @@ (define (,(format-symbol "parse-~a" name) input) (match input [(and ,@(for/list [(named-pat facets)] (pattern->match-pattern named-pat '_))) - ,(construct name #f ty)] + ,(construct name ty)] [_ eof])) ,(parse!-definition name) @@ -181,30 +181,30 @@ [(define/generic *->preserve ->preserve) (define (->preserve preservable) (match preservable - [,(deconstruct name #f ty) + [,(deconstruct name ty) ,(pattern->unparser pattern 'src)]))] ]) (define (,(format-symbol "parse-~a" name) input) (match input [,(pattern->match-pattern pattern 'dest) - ,(construct name #f ty)] + ,(construct name ty)] [_ eof])) ,(parse!-definition name) ,@acc ]])) -(define (deconstruct name wrap? ty) +(define (deconstruct name ty) (match ty [(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))] [(ty-unit) `(,name)] - [_ (if wrap? `(,name src) 'src)])) + [_ `(,name src)])) -(define (construct name wrap? ty) +(define (construct name ty) (match ty [(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))] [(ty-unit) `(,name)] - [_ (if wrap? `(,name dest) 'dest)])) + [_ `(,name dest)])) (define (schema->module-stx name lookup-module-path schema #:translation-paths [translation-paths #f] diff --git a/implementations/racket/preserves/preserves-schema/gen/schema.rkt b/implementations/racket/preserves/preserves-schema/gen/schema.rkt index 2040d22..920fe67 100644 --- a/implementations/racket/preserves/preserves-schema/gen/schema.rkt +++ b/implementations/racket/preserves/preserves-schema/gen/schema.rkt @@ -297,7 +297,7 @@ (define (->preserve preservable) (match preservable - (src + ((Definitions src) (for/hash (((key value) (in-dict src))) (values key (*->preserve value)))))))) @@ -313,7 +313,7 @@ (cons key value) make-immutable-hash dest) - dest) + (Definitions dest)) (_ eof))) (define parse-Definitions! (parse-success-or-error 'parse-Definitions parse-Definitions)) @@ -327,7 +327,7 @@ (define (->preserve preservable) (match preservable - (src + ((DictionaryEntries src) (for/hash (((key value) (in-dict src))) (values key (*->preserve value)))))))) @@ -341,7 +341,7 @@ (cons key value) make-immutable-hash dest) - dest) + (DictionaryEntries dest)) (_ eof))) (define parse-DictionaryEntries! (parse-success-or-error 'parse-DictionaryEntries parse-DictionaryEntries)) @@ -381,9 +381,14 @@ gen:preservable ((define/generic *->preserve ->preserve) (define (->preserve preservable) - (match preservable (src (for/list ((item (in-list src))) item)))))) + (match + preservable + ((ModulePath src) (for/list ((item (in-list src))) item)))))) (define (parse-ModulePath input) - (match input ((list (and dest (? symbol?)) ...) dest) (_ eof))) + (match + input + ((list (and dest (? symbol?)) ...) (ModulePath dest)) + (_ eof))) (define parse-ModulePath! (parse-success-or-error 'parse-ModulePath parse-ModulePath)) (struct @@ -396,7 +401,7 @@ (define (->preserve preservable) (match preservable - (src + ((Modules src) (for/hash (((key value) (in-dict src))) (values (*->preserve key) (*->preserve value)))))))) @@ -412,7 +417,7 @@ (cons key value) make-immutable-hash dest) - dest) + (Modules dest)) (_ eof))) (define parse-Modules! (parse-success-or-error 'parse-Modules parse-Modules)) (struct diff --git a/implementations/racket/preserves/preserves-schema/parser.rkt b/implementations/racket/preserves/preserves-schema/parser.rkt index 11efd92..a2426a4 100644 --- a/implementations/racket/preserves/preserves-schema/parser.rkt +++ b/implementations/racket/preserves/preserves-schema/parser.rkt @@ -66,7 +66,7 @@ (pattern->match-pattern variable-named-pat '_) `(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats) ,(pattern->match-pattern variable-named-pat '_))))] - [(CompoundPattern-dict entries) + [(CompoundPattern-dict (DictionaryEntries entries)) (maybe-dest dest-pat-stx `(hash-table ,@(map (lambda (entry) `(,(literal->pattern (car entry)) @@ -75,11 +75,11 @@ (_ _) ...))])) (define (Ref-parser-name r) - (match-define (Ref module-path name) r) + (match-define (Ref (ModulePath module-path) name) r) (format-symbol "~aparse-~a" (module-path-prefix module-path) name)) (define (Ref-parser!-name r) - (match-define (Ref module-path name) r) + (match-define (Ref (ModulePath module-path) name) r) (format-symbol "~aparse-~a!" (module-path-prefix module-path) name)) (define (literal->pattern v) diff --git a/implementations/racket/preserves/preserves-schema/reader.rkt b/implementations/racket/preserves/preserves-schema/reader.rkt index aa1fde5..e74cf21 100644 --- a/implementations/racket/preserves/preserves-schema/reader.rkt +++ b/implementations/racket/preserves/preserves-schema/reader.rkt @@ -62,12 +62,12 @@ (process toplevel-tokens source) (when (not version) (error 'parse-schema "Missing version declaration")) - (Schema definitions embeddedType version)) + (Schema (Definitions definitions) embeddedType version)) (define (parse-ref-dsl s) (match-define (list module-path ... final-id) (map string->symbol (string-split (symbol->string s) "."))) - (Ref module-path final-id)) + (Ref (ModulePath module-path) final-id)) (define (parse-def-dsl name def-stx) (define (and-branch input) @@ -158,12 +158,13 @@ [(list item ...) (CompoundPattern-tuple (map maybe-named item))] [(? dict? d) #:when (not (dict-has-key? (strip-annotations d) '...)) - (CompoundPattern-dict (for/hash [((k0 vp) (in-dict d))] - (define k (strip-annotations k0)) - (values k ((maybe-named* NamedSimplePattern-named - NamedSimplePattern-anonymous - walk-simple - k) vp))))] + (CompoundPattern-dict (DictionaryEntries + (for/hash [((k0 vp) (in-dict d))] + (define k (strip-annotations k0)) + (values k ((maybe-named* NamedSimplePattern-named + NamedSimplePattern-anonymous + walk-simple + k) vp)))))] [_ (error 'parse-pattern-dsl "Invalid pattern: ~a" (input->string input))])) (define (walk stx) (parse-pattern-dsl name (list stx))) diff --git a/implementations/racket/preserves/preserves-schema/type.rkt b/implementations/racket/preserves/preserves-schema/type.rkt index a8b018a..ea47887 100644 --- a/implementations/racket/preserves/preserves-schema/type.rkt +++ b/implementations/racket/preserves/preserves-schema/type.rkt @@ -78,7 +78,7 @@ (gather-fields* named-pats acc)] [(CompoundPattern-tuple* fixed-named-pats variable-named-pat) (gather-fields* fixed-named-pats (gather-fields variable-named-pat acc))] - [(CompoundPattern-dict entries) + [(CompoundPattern-dict (DictionaryEntries entries)) (gather-fields* (map cdr (sorted-dict-entries entries)) acc)])) (define (pattern-ty p) diff --git a/implementations/racket/preserves/preserves-schema/unparser.rkt b/implementations/racket/preserves/preserves-schema/unparser.rkt index 825aa58..d5d1752 100644 --- a/implementations/racket/preserves/preserves-schema/unparser.rkt +++ b/implementations/racket/preserves/preserves-schema/unparser.rkt @@ -34,7 +34,7 @@ [(CompoundPattern-tuple* fixed-named-pats variable-named-pat) `(list* ,@(for/list [(p (in-list fixed-named-pats))] (pattern->unparser p src-stx)) ,(pattern->unparser variable-named-pat src-stx))] - [(CompoundPattern-dict entries) + [(CompoundPattern-dict (DictionaryEntries entries)) `(hash ,@(append-map (lambda (entry) (list `',(car entry) (pattern->unparser (cdr entry) src-stx)))