From c4bfc0eefc9c8af86bd5da8f21d98591846e17cb Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 24 May 2021 10:09:17 +0200 Subject: [PATCH] Follow improvements through Racket schema impl --- .../preserves/preserves-schema/gen/schema.rkt | 83 ++++++++++--------- .../preserves/preserves-schema/parser.rkt | 30 +++---- .../preserves/preserves-schema/type.rkt | 16 ++-- .../preserves/preserves-schema/unparser.rkt | 17 ++-- 4 files changed, 70 insertions(+), 76 deletions(-) diff --git a/implementations/racket/preserves/preserves-schema/gen/schema.rkt b/implementations/racket/preserves/preserves-schema/gen/schema.rkt index f075dac..7b6f5e9 100644 --- a/implementations/racket/preserves/preserves-schema/gen/schema.rkt +++ b/implementations/racket/preserves/preserves-schema/gen/schema.rkt @@ -14,11 +14,17 @@ (SimplePattern-atom? p) (SimplePattern-embedded? p) (SimplePattern-lit? p) + (SimplePattern-seqof? p) + (SimplePattern-setof? p) + (SimplePattern-dictof? p) (SimplePattern-Ref? p))) (struct SimplePattern-any () #:prefab) (struct SimplePattern-atom (atomKind) #:prefab) (struct SimplePattern-embedded () #:prefab) (struct SimplePattern-lit (value) #:prefab) + (struct SimplePattern-seqof (pattern) #:prefab) + (struct SimplePattern-setof (pattern) #:prefab) + (struct SimplePattern-dictof (key value) #:prefab) (struct SimplePattern-Ref (value) #:prefab) (struct NamedAlternative (variantLabel pattern) #:prefab) (struct Schema (version embeddedType definitions) #:prefab) @@ -30,14 +36,10 @@ (or (CompoundPattern-rec? p) (CompoundPattern-tuple? p) (CompoundPattern-tuple*? p) - (CompoundPattern-setof? p) - (CompoundPattern-dictof? p) (CompoundPattern-dict? p))) (struct CompoundPattern-rec (label fields) #:prefab) (struct CompoundPattern-tuple (patterns) #:prefab) (struct CompoundPattern-tuple* (fixed variable) #:prefab) - (struct CompoundPattern-setof (pattern) #:prefab) - (struct CompoundPattern-dictof (key value) #:prefab) (struct CompoundPattern-dict (entries) #:prefab) (struct Ref (module name) #:prefab) (struct Bundle (modules) #:prefab) @@ -89,6 +91,23 @@ (SimplePattern-atom $atomKind)) ((and dest (record 'embedded (list))) (SimplePattern-embedded)) ((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-NamedAlternative input) @@ -153,31 +172,17 @@ (record 'tuple (list - (list* - (list - (app parse-NamedPattern (and $patterns (not (== eof)))) - ...))))) + (list + (app parse-NamedPattern (and $patterns (not (== eof)))) + ...)))) (CompoundPattern-tuple $patterns)) ((and dest (record 'tuple* (list - (list* - (list (app parse-NamedPattern (and $fixed (not (== eof)))) ...)) + (list (app parse-NamedPattern (and $fixed (not (== eof)))) ...) (app parse-NamedSimplePattern (and $variable (not (== eof))))))) (CompoundPattern-tuple* $fixed $variable)) - ((and dest - (record - 'setof - (list (app parse-SimplePattern (and $pattern (not (== eof))))))) - (CompoundPattern-setof $pattern)) - ((and dest - (record - 'dictof - (list - (app parse-SimplePattern (and $key (not (== eof)))) - (app parse-SimplePattern (and $value (not (== eof))))))) - (CompoundPattern-dictof $key $value)) ((and dest (record 'dict @@ -272,11 +277,7 @@ ((and dest (== '#f)) (EmbeddedTypeName-false)) (_ eof))) (define (parse-ModulePath input) - (match - input - ((parse-sequence list? values (and item (? symbol?)) item values dest) - dest) - (_ eof))) + (match input ((list (and dest (? symbol?)) ...) dest) (_ eof))) (define (parse-AtomKind input) (match input @@ -315,6 +316,16 @@ (record 'atom (list (AtomKind->preserves $atomKind)))) ((SimplePattern-embedded) (record 'embedded (list))) ((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 (NamedAlternative->preserves input) (match @@ -360,25 +371,15 @@ (record 'tuple (list - (list* - (for/list - ((item (in-list $patterns))) - (NamedPattern->preserves item)))))) + (for/list + ((item (in-list $patterns))) + (NamedPattern->preserves item))))) ((CompoundPattern-tuple* $fixed $variable) (record 'tuple* (list - (list* - (for/list ((item (in-list $fixed))) (NamedPattern->preserves item))) + (for/list ((item (in-list $fixed))) (NamedPattern->preserves item)) (NamedSimplePattern->preserves $variable)))) - ((CompoundPattern-setof $pattern) - (record 'setof (list (SimplePattern->preserves $pattern)))) - ((CompoundPattern-dictof $key $value) - (record - 'dictof - (list - (SimplePattern->preserves $key) - (SimplePattern->preserves $value)))) ((CompoundPattern-dict $entries) (record 'dict (list (DictionaryEntries->preserves $entries)))))) (define (Modules->preserves input) diff --git a/implementations/racket/preserves/preserves-schema/parser.rkt b/implementations/racket/preserves/preserves-schema/parser.rkt index 7bb0d90..9b61758 100644 --- a/implementations/racket/preserves/preserves-schema/parser.rkt +++ b/implementations/racket/preserves/preserves-schema/parser.rkt @@ -60,25 +60,16 @@ [(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))))] - [(SimplePattern-Ref (Ref module-path name)) - (error 'pattern-parser "Ref with non-empty module path not yet implemented")] - [(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat)) - `(parse-sequence list? - values - ,(pattern->match-pattern variable-pat 'item) - item - values - ,dest-pat-stx)] - [(CompoundPattern-setof pat) + [(SimplePattern-seqof variable-pat) + `(list ,(pattern->match-pattern variable-pat dest-pat-stx) ...)] + [(SimplePattern-setof pat) `(parse-sequence set? set->list ,(pattern->match-pattern pat 'item) item list->set ,dest-pat-stx)] - [(CompoundPattern-dictof key-pat value-pat) + [(SimplePattern-dictof key-pat value-pat) `(parse-sequence dict? dict->list (cons ,(pattern->match-pattern key-pat 'key) @@ -86,17 +77,22 @@ (cons key value) make-immutable-hash ,dest-pat-stx)] + [(SimplePattern-Ref (Ref '() name)) + `(app ,(format-symbol "parse-~a" name) ,(maybe-dest dest-pat-stx `(not (== eof))))] + [(SimplePattern-Ref (Ref module-path name)) + (error 'pattern-parser "Ref with non-empty module path not yet implemented")] [(CompoundPattern-rec label-pat fields-pat) (maybe-dest dest-pat-stx `(record ,(pattern->match-pattern label-pat '_) ,(pattern->match-pattern fields-pat '_)))] [(CompoundPattern-tuple named-pats) (maybe-dest dest-pat-stx `(list ,@(map (lambda (p) (pattern->match-pattern p '_)) named-pats)))] - [(CompoundPattern-tuple* fixed-named-pats - (NamedSimplePattern-named (NamedSimplePattern_ vname vpat))) + [(CompoundPattern-tuple* fixed-named-pats variable-named-pat) (maybe-dest dest-pat-stx - `(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats) - (list ,(pattern->match-pattern vpat (escape vname)) ...)))] + (if (null? fixed-named-pats) + (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 (hash-table (keys pats) ...)) (maybe-dest dest-pat-stx `(hash-table ,@(for/list [(key (in-list keys)) diff --git a/implementations/racket/preserves/preserves-schema/type.rkt b/implementations/racket/preserves/preserves-schema/type.rkt index e90cd26..b4dafd4 100644 --- a/implementations/racket/preserves/preserves-schema/type.rkt +++ b/implementations/racket/preserves/preserves-schema/type.rkt @@ -61,15 +61,15 @@ (match (pattern-ty p) [(ty-unit) acc] [ty (cons (list n ty) acc)])] + [(? SimplePattern?) acc] [(CompoundPattern-rec label-named-pat fields-named-pat) (gather-fields label-named-pat (gather-fields fields-named-pat acc))] - [(CompoundPattern-tuple named-pats) (gather-fields* named-pats acc)] + [(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))] [(CompoundPattern-dict (hash-table (keys pats) ...)) - (gather-fields* (map add-name-if-absent keys pats) acc)] - [(? SimplePattern?) acc] - [(? CompoundPattern?) acc])) + (gather-fields* (map add-name-if-absent keys pats) acc)])) (define (pattern-ty p) (match (unwrap p) @@ -77,12 +77,10 @@ [(SimplePattern-atom _atomKind) (ty-value)] [(SimplePattern-embedded) (ty-value)] [(SimplePattern-lit _value) (ty-unit)] + [(SimplePattern-seqof pat) (ty-array (pattern-ty pat))] + [(SimplePattern-setof pat) (ty-set (pattern-ty pat))] + [(SimplePattern-dictof kp vp) (ty-dictionary (pattern-ty kp) (pattern-ty vp))] [(SimplePattern-Ref _r) (ty-value)] - [(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat)) - (ty-array (pattern-ty variable-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))] [(? CompoundPattern?) (product-ty (list p))])) (define (add-name-if-absent k p) diff --git a/implementations/racket/preserves/preserves-schema/unparser.rkt b/implementations/racket/preserves/preserves-schema/unparser.rkt index b776138..c7be00c 100644 --- a/implementations/racket/preserves/preserves-schema/unparser.rkt +++ b/implementations/racket/preserves/preserves-schema/unparser.rkt @@ -58,25 +58,24 @@ [(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")] - [(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat)) + [(SimplePattern-seqof variable-pat) `(for/list [(item (in-list ,src-stx))] ,(pattern->unparser variable-pat 'item))] - [(CompoundPattern-setof pat) + [(SimplePattern-setof pat) `(for/set [(item (in-set ,src-stx))] ,(pattern->unparser pat 'item))] - [(CompoundPattern-dictof key-pat value-pat) + [(SimplePattern-dictof key-pat value-pat) `(for/hash [((key value) (in-dict ,src-stx))] (values ,(pattern->unparser key-pat 'key) ,(pattern->unparser value-pat 'value)))] + [(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")] [(CompoundPattern-rec label-pat fields-pat) `(record ,(pattern->unparser label-pat src-stx) ,(pattern->unparser fields-pat src-stx))] [(CompoundPattern-tuple named-pats) `(list ,@(for/list [(p (in-list named-pats))] (pattern->unparser p src-stx)))] - [(CompoundPattern-tuple* fixed-named-pats - (NamedSimplePattern-named (NamedSimplePattern_ vname vpat))) + [(CompoundPattern-tuple* fixed-named-pats variable-named-pat) `(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)))] + ,(pattern->unparser variable-named-pat src-stx))] [(CompoundPattern-dict (hash-table (keys pats) ...)) `(hash ,@(append-map (lambda (key pat) (list `',key (pattern->unparser (add-name-if-absent key pat) src-stx)))