Deterministic hash ordering for Racket CompoundPattern-dict

This commit is contained in:
Tony Garnock-Jones 2021-05-24 17:46:50 +02:00
parent 33a80533fa
commit bdd699ae9f
5 changed files with 28 additions and 24 deletions

View File

@ -4,6 +4,7 @@
(require racket/match)
(require (only-in racket/list check-duplicates))
(require preserves/order)
(require (only-in "type.rkt" unwrap add-name-if-absent))
(require "gen/schema.rkt")
@ -34,8 +35,8 @@
(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)
(for [((k v) (in-hash entries))]
(check-named-pattern (cons k context) scope (add-name-if-absent k v)))]))
(for [(entry (in-list (sorted-dict-entries entries)))]
(check-named-pattern (cons (car entry) context) scope (add-name-if-absent entry)))]))
(define (check-named-pattern context scope p)
(match (unwrap p)

View File

@ -27,7 +27,7 @@
(struct SimplePattern-dictof (key value) #:prefab)
(struct SimplePattern-Ref (value) #:prefab)
(struct NamedAlternative (variantLabel pattern) #:prefab)
(struct Schema (version embeddedType definitions) #:prefab)
(struct Schema (definitions embeddedType version) #:prefab)
(define (Pattern? p)
(or (Pattern-SimplePattern? p) (Pattern-CompoundPattern? p)))
(struct Pattern-SimplePattern (value) #:prefab)
@ -141,14 +141,14 @@
'schema
(list
(hash-table
('version (app parse-Version (and $version (not (== eof)))))
('embeddedType
(app parse-EmbeddedTypeName (and $embeddedType (not (== eof)))))
('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 $version $embeddedType $definitions))
(Schema $definitions $embeddedType $version))
(_ eof)))
(define (parse-Pattern input)
(match
@ -342,17 +342,17 @@
(define (Schema->preserves input)
(match
input
((Schema $version $embeddedType $definitions)
((Schema $definitions $embeddedType $version)
(record
'schema
(list
(hash
'version
(Version->preserves $version)
'definitions
(Definitions->preserves $definitions)
'embeddedType
(EmbeddedTypeName->preserves $embeddedType)
'definitions
(Definitions->preserves $definitions)))))))
'version
(Version->preserves $version)))))))
(define (Pattern->preserves input)
(match
input

View File

@ -93,12 +93,12 @@
(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) ...))
[(CompoundPattern-dict entries)
(maybe-dest dest-pat-stx
`(hash-table ,@(for/list [(key (in-list keys))
(pat (in-list pats))]
`(,(literal->pattern key)
,(pattern->match-pattern (add-name-if-absent key pat) '_)))
`(hash-table ,@(map (lambda (entry)
`(,(literal->pattern (car entry))
,(pattern->match-pattern (add-name-if-absent entry) '_)))
(sorted-dict-entries entries))
(_ _) ...))]))
(define (literal->pattern v)

View File

@ -14,6 +14,7 @@
escape)
(require preserves/record)
(require preserves/order)
(require racket/match)
(require (only-in racket/syntax format-symbol))
@ -68,8 +69,8 @@
(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)]))
[(CompoundPattern-dict entries)
(gather-fields* (map add-name-if-absent (sorted-dict-entries entries)) acc)]))
(define (pattern-ty p)
(match (unwrap p)
@ -83,7 +84,8 @@
[(SimplePattern-Ref _r) (ty-value)]
[(? CompoundPattern?) (product-ty (list p))]))
(define (add-name-if-absent k p)
(define (add-name-if-absent entry)
(match-define (cons k p) entry)
(match p
[(NamedSimplePattern-named _) p]
[(NamedSimplePattern-anonymous _)

View File

@ -76,7 +76,8 @@
[(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 (hash-table (keys pats) ...))
`(hash ,@(append-map (lambda (key pat)
(list `',key (pattern->unparser (add-name-if-absent key pat) src-stx)))
keys pats))]))
[(CompoundPattern-dict entries)
`(hash ,@(append-map (lambda (entry)
(list `',(car entry)
(pattern->unparser (add-name-if-absent entry) src-stx)))
(sorted-dict-entries entries)))]))