From 43b776eb7f3bc8beb7a4661a6d43a012b1e39191 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 22 May 2021 15:47:13 +0200 Subject: [PATCH] Switch to manipulating parsed form of metaschema --- .../preserves/preserves-schema/main.rkt | 31 +++---- .../preserves/preserves-schema/parser.rkt | 59 ++++++------- .../preserves/preserves-schema/type.rkt | 82 +++++++++++++------ .../preserves/preserves-schema/unparser.rkt | 44 +++++----- 4 files changed, 126 insertions(+), 90 deletions(-) diff --git a/implementations/racket/preserves/preserves-schema/main.rkt b/implementations/racket/preserves/preserves-schema/main.rkt index a695663..afcaf78 100644 --- a/implementations/racket/preserves/preserves-schema/main.rkt +++ b/implementations/racket/preserves/preserves-schema/main.rkt @@ -10,18 +10,14 @@ (require "type.rkt") (require "parser.rkt") (require "unparser.rkt") +(require "gen-schema.rkt") (define (struct-stx name-pieces field-names) `(struct ,(string->symbol (string-join (map ~a name-pieces) "-")) ,field-names #:prefab)) -(define (schema-definition-table schema) - (match schema - [(record 'schema (list (hash-table ('definitions definition-table) (_ _) ...))) - definition-table])) - (define (struct-defs schema) (reverse (for/fold [(acc '())] - [((name def) (in-hash (schema-definition-table schema)))] + [((name def) (in-hash (Schema-definitions schema)))] (match (definition-ty def) [(ty-union variants) (for/fold [(acc acc)] @@ -40,11 +36,11 @@ acc])))) (define (parser-defs schema) - (for/list [((name def) (in-hash (schema-definition-table schema)))] + (for/list [((name def) (in-hash (Schema-definitions schema)))] (definition-parser name def))) (define (unparser-defs schema) - (for/list [((name def) (in-hash (schema-definition-table schema)))] + (for/list [((name def) (in-hash (Schema-definitions schema)))] (definition-unparser name def))) (define (schema->module-stx name schema) @@ -55,15 +51,20 @@ (require racket/match) (require racket/set) (require racket/dict) + ;; TODO: overall predicate for e.g. CompoundPattern, anything with an alternation ,@(struct-defs schema) ,@(parser-defs schema) - ,@(unparser-defs schema))) + ,@(unparser-defs schema) + )) (module+ main (require racket/pretty) - (with-output-to-file "gen-schema.rkt" #:exists 'replace - (lambda () - (pretty-write - (schema->module-stx - 'gen-schema - (with-input-from-file "../../../../schema/schema.bin" read-preserve)))))) + (define metaschema-module-source + (schema->module-stx + 'gen-schema + (parse-Schema + (with-input-from-file "../../../../schema/schema.bin" read-preserve)))) + (if #t + (with-output-to-file "gen-schema.rkt" #:exists 'replace + (lambda () (pretty-write metaschema-module-source))) + (pretty-write metaschema-module-source))) diff --git a/implementations/racket/preserves/preserves-schema/parser.rkt b/implementations/racket/preserves/preserves-schema/parser.rkt index 06e763b..c61de10 100644 --- a/implementations/racket/preserves/preserves-schema/parser.rkt +++ b/implementations/racket/preserves/preserves-schema/parser.rkt @@ -7,25 +7,27 @@ (require (only-in racket/syntax format-symbol)) (require "type.rkt") +(require "gen-schema.rkt") (define (definition-parser name def) (define ty (definition-ty def)) `(define (,(format-symbol "parse-~a" name) input) ,(match def - [(record 'or (list named-alts)) + [(Definition-or p0 p1 pN) `(match input - ,@(for/list [(named-alt (in-list named-alts)) + ,@(for/list [(named-alt (in-list (list* p0 p1 pN))) (alt-ty (in-list (map cadr (ty-union-variants ty))))] - (match-define (list variant-label-str pattern) named-alt) + (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])] - [(record 'and (list named-pats)) + [(Definition-and p0 p1 pN) `(match input - [(and ,@(for/list [(named-pat named-pats)] (pattern->match-pattern named-pat '_))) + [(and ,@(for/list [(named-pat (list* p0 p1 pN))] + (pattern->match-pattern named-pat '_))) ,(construct name #f ty)] [_ eof])] - [pattern + [(Definition-Pattern pattern) `(match input [,(pattern->match-pattern pattern 'dest) ,(construct name #f ty)] @@ -43,40 +45,40 @@ [_ `(and ,dest-pat-stx ,pat)])) (define (pattern->match-pattern pattern dest-pat-stx) - (match pattern - [(record 'named (list n p)) (pattern->match-pattern p (maybe-dest dest-pat-stx (escape n)))] - ['any dest-pat-stx] - [(record 'atom (list atom-kind)) + (match (unwrap pattern) + [(NamedSimplePattern_ n p) (pattern->match-pattern p (maybe-dest dest-pat-stx (escape n)))] + [(SimplePattern-any) dest-pat-stx] + [(SimplePattern-atom atom-kind) (maybe-dest dest-pat-stx `(? ,(match atom-kind - ['Boolean 'boolean?] - ['Float 'float?] - ['Double 'flonum?] - ['SignedInteger 'integer?] - ['String 'string?] - ['ByteString 'bytes?] - ['Symbol 'symbol?])))] - [(record 'embedded '()) (error 'pattern-parser "Embedded not yet implemented")] - [(record 'lit (list v)) (maybe-dest dest-pat-stx (literal->pattern v))] - [(record 'ref (list '() name)) + [(AtomKind-Boolean) 'boolean?] + [(AtomKind-Float) 'float?] + [(AtomKind-Double) 'flonum?] + [(AtomKind-SignedInteger) 'integer?] + [(AtomKind-String) 'string?] + [(AtomKind-ByteString) 'bytes?] + [(AtomKind-Symbol) 'symbol?])))] + [(SimplePattern-embedded) (error 'pattern-parser "Embedded not yet implemented")] + [(SimplePattern-lit v) (maybe-dest dest-pat-stx (literal->pattern v))] + [(SimplePattern-Ref (Ref '() name)) `(app ,(format-symbol "parse-~a" name) ,(maybe-dest dest-pat-stx `(not (== eof))))] - [(record 'ref (list module-path name)) + [(SimplePattern-Ref (Ref module-path name)) (error 'pattern-parser "Ref with non-empty module path not yet implemented")] - [(record 'tuple* (list '() (and variable-pat (not (record 'named _))))) + [(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat)) `(parse-sequence list? values ,(pattern->match-pattern variable-pat 'item) item values ,dest-pat-stx)] - [(record 'setof (list pat)) + [(CompoundPattern-setof pat) `(parse-sequence set? set->list ,(pattern->match-pattern pat 'item) item list->set ,dest-pat-stx)] - [(record 'dictof (list key-pat value-pat)) + [(CompoundPattern-dictof key-pat value-pat) `(parse-sequence dict? dict->list (cons ,(pattern->match-pattern key-pat 'key) @@ -84,17 +86,18 @@ (cons key value) make-immutable-hash ,dest-pat-stx)] - [(record 'rec (list label-pat fields-pat)) + [(CompoundPattern-rec label-pat fields-pat) (maybe-dest dest-pat-stx `(record ,(pattern->match-pattern label-pat '_) ,(pattern->match-pattern fields-pat '_)))] - [(record 'tuple (list named-pats)) + [(CompoundPattern-tuple named-pats) (maybe-dest dest-pat-stx `(list ,@(map (lambda (p) (pattern->match-pattern p '_)) named-pats)))] - [(record 'tuple* (list fixed-named-pats (record 'named (list vname vpat)))) + [(CompoundPattern-tuple* fixed-named-pats + (NamedSimplePattern-named (NamedSimplePattern_ vname vpat))) (maybe-dest dest-pat-stx `(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats) (list ,(pattern->match-pattern vpat (escape vname)) ...)))] - [(record 'dict (list (hash-table (keys pats) ...))) + [(CompoundPattern-dict (hash-table (keys pats) ...)) (maybe-dest dest-pat-stx `(hash-table ,@(for/list [(key (in-list keys)) (pat (in-list pats))] diff --git a/implementations/racket/preserves/preserves-schema/type.rkt b/implementations/racket/preserves/preserves-schema/type.rkt index 6c410b2..eb43dc0 100644 --- a/implementations/racket/preserves/preserves-schema/type.rkt +++ b/implementations/racket/preserves/preserves-schema/type.rkt @@ -9,6 +9,7 @@ (struct-out ty-dictionary) definition-ty + unwrap add-name-if-absent escape) @@ -16,6 +17,8 @@ (require racket/match) (require (only-in racket/syntax format-symbol)) +(require "gen-schema.rkt") + (struct ty-union (variants) #:transparent) (struct ty-unit () #:transparent) (struct ty-value () #:transparent) @@ -26,57 +29,84 @@ (define (definition-ty d) (match d - [(record 'or (list named-alts)) + [(Definition-or p0 p1 pN) (ty-union (map (match-lambda - [(list variant-label-str pattern) + [(NamedAlternative variant-label-str pattern) (list (string->symbol variant-label-str) (pattern-ty pattern))]) - named-alts))] - [(record 'and (list named-pats)) (product-ty named-pats)] - [pattern (pattern-ty pattern)])) + (list* p0 p1 pN)))] + [(Definition-and p0 p1 pN) (product-ty (list* p0 p1 pN))] + [(Definition-Pattern pattern) (pattern-ty pattern)])) (define (product-ty named-pats) (match (gather-fields* named-pats '()) ['() (ty-unit)] [fields (ty-record fields)])) +(define (unwrap p) + (match p + [(Pattern-SimplePattern p) (unwrap p)] + [(Pattern-CompoundPattern p) (unwrap p)] + [(NamedPattern-named p) (unwrap p)] + [(NamedSimplePattern-named p) (unwrap p)] + [(NamedPattern-anonymous p) (unwrap p)] + [(NamedSimplePattern-anonymous p) (unwrap p)] + [_ p])) + (define (gather-fields* named-pats acc) (foldr gather-fields acc named-pats)) +(define (SimplePattern? p) + (or (SimplePattern-any? p) + (SimplePattern-atom? p) + (SimplePattern-embedded? p) + (SimplePattern-lit? p) + (SimplePattern-Ref? p))) + +(define (CompoundPattern? p) + (or (CompoundPattern-rec? p) + (CompoundPattern-tuple? p) + (CompoundPattern-tuple*? p) + (CompoundPattern-setof? p) + (CompoundPattern-dictof? p) + (CompoundPattern-dict? p))) + (define (gather-fields named-pat acc) - (match named-pat - [(record 'named (list n p)) + (match (unwrap named-pat) + [(NamedSimplePattern_ n p) (match (pattern-ty p) [(ty-unit) acc] [ty (cons (list n ty) acc)])] - [(record 'rec (list label-named-pat fields-named-pat)) + [(CompoundPattern-rec label-named-pat fields-named-pat) (gather-fields label-named-pat (gather-fields fields-named-pat acc))] - [(record 'tuple (list named-pats)) (gather-fields* named-pats acc)] - [(record 'tuple* (list fixed-named-pats variable-named-pat)) + [(CompoundPattern-tuple named-pats) (gather-fields* named-pats acc)] + [(CompoundPattern-tuple* fixed-named-pats variable-named-pat) (gather-fields* fixed-named-pats (gather-fields variable-named-pat acc))] - [(record 'dict (list (hash-table (keys pats) ...))) + [(CompoundPattern-dict (hash-table (keys pats) ...)) (gather-fields* (map add-name-if-absent keys pats) acc)] - [_ acc])) + [(? SimplePattern?) acc] + [(? CompoundPattern?) acc])) (define (pattern-ty p) - (match p - ['any (ty-value)] - [(record 'atom (list _atom-kind)) (ty-value)] - [(record 'embedded '()) (ty-value)] - [(record 'lit (list _value)) (ty-unit)] - [(record 'ref (list _module-path _name)) (ty-value)] - [(record 'tuple* (list '() (and variable-pat (not (record 'named _))))) + (match (unwrap p) + [(SimplePattern-any) (ty-value)] + [(SimplePattern-atom _atomKind) (ty-value)] + [(SimplePattern-embedded) (ty-value)] + [(SimplePattern-lit _value) (ty-unit)] + [(SimplePattern-Ref _r) (ty-value)] + [(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat)) (ty-array (pattern-ty variable-pat))] - [(record 'setof (list pat)) (ty-set (pattern-ty pat))] - [(record 'dictof (list key-pat value-pat)) + [(CompoundPattern-setof pat) (ty-set (pattern-ty pat))] + [(CompoundPattern-dictof key-pat value-pat) (ty-dictionary (pattern-ty key-pat) (pattern-ty value-pat))] - [_ (product-ty (list p))])) + [(? CompoundPattern?) (product-ty (list p))])) (define (add-name-if-absent k p) (match p - [(record 'named _) p] - [_ (match (namelike k) - [#f p] - [s (record 'named (list s p))])])) + [(NamedSimplePattern-named _) p] + [(NamedSimplePattern-anonymous _) + (match (namelike k) + [#f p] + [s (NamedSimplePattern-named (NamedSimplePattern_ s p))])])) (define (namelike v) (match v diff --git a/implementations/racket/preserves/preserves-schema/unparser.rkt b/implementations/racket/preserves/preserves-schema/unparser.rkt index 83149ce..2374d02 100644 --- a/implementations/racket/preserves/preserves-schema/unparser.rkt +++ b/implementations/racket/preserves/preserves-schema/unparser.rkt @@ -8,6 +8,7 @@ (require (only-in racket/list append-map)) (require "type.rkt") +(require "gen-schema.rkt") (define (simple-pattern? p) (match p @@ -22,14 +23,14 @@ (define ty (definition-ty def)) `(define (,(format-symbol "~a->preserves" name) input) ,(match def - [(record 'or (list named-alts)) + [(Definition-or p0 p1 pN) `(match input - ,@(for/list [(named-alt (in-list named-alts)) + ,@(for/list [(named-alt (in-list (list* p0 p1 pN))) (alt-ty (in-list (map cadr (ty-union-variants ty))))] - (match-define (list variant-label-str pattern) named-alt) + (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)]))] - [(record 'and (list named-pats)) + [(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"))) @@ -38,8 +39,8 @@ (if (simple-pattern? named-pat) '() (list (pattern->unparser named-pat 'src)))) - named-pats))])] - [pattern + (list* p0 p1 pN)))])] + [(Definition-Pattern pattern) `(match input [,(deconstruct name #f ty) ,(pattern->unparser pattern 'src)])]))) @@ -51,31 +52,32 @@ [_ (if wrap? `(,name src) 'src)])) (define (pattern->unparser pattern src-stx) - (match pattern - [(record 'named (list n p)) (pattern->unparser p (escape n))] - ['any src-stx] - [(record 'atom (list _atom-kind)) src-stx] - [(record 'embedded '()) (error 'pattern-parser "Embedded not yet implemented")] - [(record 'lit (list v)) `',v] - [(record 'ref (list '() name)) `(,(format-symbol "~a->preserves" name) ,src-stx)] - [(record 'ref (list module-path name)) + (match (unwrap pattern) + [(NamedSimplePattern_ n p) (pattern->unparser p (escape n))] + [(SimplePattern-any) src-stx] + [(SimplePattern-atom _) src-stx] + [(SimplePattern-embedded) (error 'pattern-parser "Embedded not yet implemented")] + [(SimplePattern-lit v) `',v] + [(SimplePattern-Ref (Ref '() name)) `(,(format-symbol "~a->preserves" name) ,src-stx)] + [(SimplePattern-Ref (Ref module-path name)) (error 'pattern-parser "Ref with non-empty module path not yet implemented")] - [(record 'tuple* (list '() (and variable-pat (not (record 'named _))))) + [(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat)) `(for/list [(item (in-list ,src-stx))] ,(pattern->unparser variable-pat 'item))] - [(record 'setof (list pat)) + [(CompoundPattern-setof pat) `(for/set [(item (in-set ,src-stx))] ,(pattern->unparser pat 'item))] - [(record 'dictof (list key-pat value-pat)) + [(CompoundPattern-dictof key-pat value-pat) `(for/hash [((key value) (in-dict ,src-stx))] (values ,(pattern->unparser key-pat 'key) ,(pattern->unparser value-pat 'value)))] - [(record 'rec (list label-pat fields-pat)) + [(CompoundPattern-rec label-pat fields-pat) `(record ,(pattern->unparser label-pat src-stx) ,(pattern->unparser fields-pat src-stx))] - [(record 'tuple (list named-pats)) + [(CompoundPattern-tuple named-pats) `(list ,@(for/list [(p (in-list named-pats))] (pattern->unparser p src-stx)))] - [(record 'tuple* (list fixed-named-pats (record 'named (list vname vpat)))) + [(CompoundPattern-tuple* fixed-named-pats + (NamedSimplePattern-named (NamedSimplePattern_ vname vpat))) `(list* ,@(for/list [(p (in-list fixed-named-pats))] (pattern->unparser p src-stx)) (for/list [(item (in-list ,(escape vname)))] ,(pattern->unparser vpat 'item)))] - [(record 'dict (list (hash-table (keys pats) ...))) + [(CompoundPattern-dict (hash-table (keys pats) ...)) `(hash ,@(append-map (lambda (key pat) (list `',key (pattern->unparser (add-name-if-absent key pat) src-stx))) keys pats))]))