Deterministic hash ordering for Racket CompoundPattern-dict

implementations/racket/preserves/preserves-schema/checker.rkt

@@ -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))]
+       (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)
     (match (unwrap p)

implementations/racket/preserves/preserves-schema/gen/schema.rkt

@@ -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
+         'definitions
-         (Version->preserves $version)
+         (Definitions->preserves $definitions)
          'embeddedType
          (EmbeddedTypeName->preserves $embeddedType)
-         'definitions
+         'version
-         (Definitions->preserves $definitions)))))))
+         (Version->preserves $version)))))))
   (define (Pattern->preserves input)
     (match
      input

implementations/racket/preserves/preserves-schema/parser.rkt

@@ -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))
+                 `(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)

implementations/racket/preserves/preserves-schema/type.rkt

@@ -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) ...))
+    [(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)
   (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 _)

implementations/racket/preserves/preserves-schema/unparser.rkt

@@ -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) ...))
+    [(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)))]))