Deterministic hash ordering for Racket CompoundPattern-dict
This commit is contained in:
parent
33a80533fa
commit
bdd699ae9f
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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 _)
|
||||
|
|
|
@ -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)))]))
|
||||
|
|
Loading…
Reference in New Issue