forked from syndicate-lang/preserves
Deterministic hash ordering for Racket CompoundPattern-dict
This commit is contained in:
parent
33a80533fa
commit
bdd699ae9f
|
@ -4,6 +4,7 @@
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require (only-in racket/list check-duplicates))
|
(require (only-in racket/list check-duplicates))
|
||||||
|
(require preserves/order)
|
||||||
|
|
||||||
(require (only-in "type.rkt" unwrap add-name-if-absent))
|
(require (only-in "type.rkt" unwrap add-name-if-absent))
|
||||||
(require "gen/schema.rkt")
|
(require "gen/schema.rkt")
|
||||||
|
@ -34,8 +35,8 @@
|
||||||
(for [(p (in-list ps)) (i (in-naturals))] (check-named-pattern (cons i context) scope p))
|
(for [(p (in-list ps)) (i (in-naturals))] (check-named-pattern (cons i context) scope p))
|
||||||
(check-named-pattern (cons "tail" context) scope v)]
|
(check-named-pattern (cons "tail" context) scope v)]
|
||||||
[(CompoundPattern-dict entries)
|
[(CompoundPattern-dict entries)
|
||||||
(for [((k v) (in-hash entries))]
|
(for [(entry (in-list (sorted-dict-entries entries)))]
|
||||||
(check-named-pattern (cons k context) scope (add-name-if-absent k v)))]))
|
(check-named-pattern (cons (car entry) context) scope (add-name-if-absent entry)))]))
|
||||||
|
|
||||||
(define (check-named-pattern context scope p)
|
(define (check-named-pattern context scope p)
|
||||||
(match (unwrap p)
|
(match (unwrap p)
|
||||||
|
|
|
@ -27,7 +27,7 @@
|
||||||
(struct SimplePattern-dictof (key value) #:prefab)
|
(struct SimplePattern-dictof (key value) #:prefab)
|
||||||
(struct SimplePattern-Ref (value) #:prefab)
|
(struct SimplePattern-Ref (value) #:prefab)
|
||||||
(struct NamedAlternative (variantLabel pattern) #:prefab)
|
(struct NamedAlternative (variantLabel pattern) #:prefab)
|
||||||
(struct Schema (version embeddedType definitions) #:prefab)
|
(struct Schema (definitions embeddedType version) #:prefab)
|
||||||
(define (Pattern? p)
|
(define (Pattern? p)
|
||||||
(or (Pattern-SimplePattern? p) (Pattern-CompoundPattern? p)))
|
(or (Pattern-SimplePattern? p) (Pattern-CompoundPattern? p)))
|
||||||
(struct Pattern-SimplePattern (value) #:prefab)
|
(struct Pattern-SimplePattern (value) #:prefab)
|
||||||
|
@ -141,14 +141,14 @@
|
||||||
'schema
|
'schema
|
||||||
(list
|
(list
|
||||||
(hash-table
|
(hash-table
|
||||||
('version (app parse-Version (and $version (not (== eof)))))
|
|
||||||
('embeddedType
|
|
||||||
(app parse-EmbeddedTypeName (and $embeddedType (not (== eof)))))
|
|
||||||
('definitions
|
('definitions
|
||||||
(app parse-Definitions (and $definitions (not (== eof)))))
|
(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)))
|
(_ eof)))
|
||||||
(define (parse-Pattern input)
|
(define (parse-Pattern input)
|
||||||
(match
|
(match
|
||||||
|
@ -342,17 +342,17 @@
|
||||||
(define (Schema->preserves input)
|
(define (Schema->preserves input)
|
||||||
(match
|
(match
|
||||||
input
|
input
|
||||||
((Schema $version $embeddedType $definitions)
|
((Schema $definitions $embeddedType $version)
|
||||||
(record
|
(record
|
||||||
'schema
|
'schema
|
||||||
(list
|
(list
|
||||||
(hash
|
(hash
|
||||||
'version
|
'definitions
|
||||||
(Version->preserves $version)
|
(Definitions->preserves $definitions)
|
||||||
'embeddedType
|
'embeddedType
|
||||||
(EmbeddedTypeName->preserves $embeddedType)
|
(EmbeddedTypeName->preserves $embeddedType)
|
||||||
'definitions
|
'version
|
||||||
(Definitions->preserves $definitions)))))))
|
(Version->preserves $version)))))))
|
||||||
(define (Pattern->preserves input)
|
(define (Pattern->preserves input)
|
||||||
(match
|
(match
|
||||||
input
|
input
|
||||||
|
|
|
@ -93,12 +93,12 @@
|
||||||
(pattern->match-pattern variable-named-pat '_)
|
(pattern->match-pattern variable-named-pat '_)
|
||||||
`(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats)
|
`(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats)
|
||||||
,(pattern->match-pattern variable-named-pat '_))))]
|
,(pattern->match-pattern variable-named-pat '_))))]
|
||||||
[(CompoundPattern-dict (hash-table (keys pats) ...))
|
[(CompoundPattern-dict entries)
|
||||||
(maybe-dest dest-pat-stx
|
(maybe-dest dest-pat-stx
|
||||||
`(hash-table ,@(for/list [(key (in-list keys))
|
`(hash-table ,@(map (lambda (entry)
|
||||||
(pat (in-list pats))]
|
`(,(literal->pattern (car entry))
|
||||||
`(,(literal->pattern key)
|
,(pattern->match-pattern (add-name-if-absent entry) '_)))
|
||||||
,(pattern->match-pattern (add-name-if-absent key pat) '_)))
|
(sorted-dict-entries entries))
|
||||||
(_ _) ...))]))
|
(_ _) ...))]))
|
||||||
|
|
||||||
(define (literal->pattern v)
|
(define (literal->pattern v)
|
||||||
|
|
|
@ -14,6 +14,7 @@
|
||||||
escape)
|
escape)
|
||||||
|
|
||||||
(require preserves/record)
|
(require preserves/record)
|
||||||
|
(require preserves/order)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require (only-in racket/syntax format-symbol))
|
(require (only-in racket/syntax format-symbol))
|
||||||
|
|
||||||
|
@ -68,8 +69,8 @@
|
||||||
(gather-fields* named-pats acc)]
|
(gather-fields* named-pats acc)]
|
||||||
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
|
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
|
||||||
(gather-fields* fixed-named-pats (gather-fields variable-named-pat acc))]
|
(gather-fields* fixed-named-pats (gather-fields variable-named-pat acc))]
|
||||||
[(CompoundPattern-dict (hash-table (keys pats) ...))
|
[(CompoundPattern-dict entries)
|
||||||
(gather-fields* (map add-name-if-absent keys pats) acc)]))
|
(gather-fields* (map add-name-if-absent (sorted-dict-entries entries)) acc)]))
|
||||||
|
|
||||||
(define (pattern-ty p)
|
(define (pattern-ty p)
|
||||||
(match (unwrap p)
|
(match (unwrap p)
|
||||||
|
@ -83,7 +84,8 @@
|
||||||
[(SimplePattern-Ref _r) (ty-value)]
|
[(SimplePattern-Ref _r) (ty-value)]
|
||||||
[(? CompoundPattern?) (product-ty (list p))]))
|
[(? 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
|
(match p
|
||||||
[(NamedSimplePattern-named _) p]
|
[(NamedSimplePattern-named _) p]
|
||||||
[(NamedSimplePattern-anonymous _)
|
[(NamedSimplePattern-anonymous _)
|
||||||
|
|
|
@ -76,7 +76,8 @@
|
||||||
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
|
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
|
||||||
`(list* ,@(for/list [(p (in-list fixed-named-pats))] (pattern->unparser p src-stx))
|
`(list* ,@(for/list [(p (in-list fixed-named-pats))] (pattern->unparser p src-stx))
|
||||||
,(pattern->unparser variable-named-pat src-stx))]
|
,(pattern->unparser variable-named-pat src-stx))]
|
||||||
[(CompoundPattern-dict (hash-table (keys pats) ...))
|
[(CompoundPattern-dict entries)
|
||||||
`(hash ,@(append-map (lambda (key pat)
|
`(hash ,@(append-map (lambda (entry)
|
||||||
(list `',key (pattern->unparser (add-name-if-absent key pat) src-stx)))
|
(list `',(car entry)
|
||||||
keys pats))]))
|
(pattern->unparser (add-name-if-absent entry) src-stx)))
|
||||||
|
(sorted-dict-entries entries)))]))
|
||||||
|
|
Loading…
Reference in New Issue