base-env: add support for hash patterns in match

Fixes racket#1363
sorawee · Mar 21, 2024 · 02af8fd · 02af8fd
1 parent 1d773eb
commit 02af8fd
Show file tree

Hide file tree

Showing 4 changed files with 64 additions and 2 deletions.
diff --git a/typed-racket-lib/info.rkt b/typed-racket-lib/info.rkt
@@ -2,7 +2,7 @@
 
 (define collection 'multi)
 
-(define deps '(("base" #:version "8.8.0.7")
+(define deps '(("base" #:version "8.12.0.14")
                "source-syntax"
                "pconvert-lib"
                "compatibility-lib" ;; to assign types

diff --git a/typed-racket-lib/typed-racket/base-env/base-env.rkt b/typed-racket-lib/typed-racket/base-env/base-env.rkt
@@ -22,7 +22,9 @@
   racket/keyword
   racket/private/stx
   (only-in mzscheme make-namespace)
-  (only-in racket/match/runtime match:error matchable? match-equality-test syntax-srclocs))
+  (only-in racket/match/runtime match:error matchable? match-equality-test syntax-srclocs
+           hash-state-step hash-shortcut-step
+           invoke-thunk hash-state hash-state-closed? hash-state-residue undef user-def))
  "base-structs.rkt"
  racket/file
  (only-in racket/private/pre-base new-apply-proc)
@@ -1360,6 +1362,29 @@
 [matchable? (unsafe-shallow:make-pred-ty (Un -String -Bytes))]
 [syntax-srclocs (Univ . -> . Univ)]
 
+;; hash table pattern matching
+[hash-state (-poly (a b) (-> (-HT a b) (-lst a) (-lst b)
+                             (-prefab 'hash-state (-HT a b) (-lst a) (-lst b))))]
+
+[hash-state-step
+ (-poly (a c) (-> a (-> (Un c -Unsafe-Undefined)) Univ
+                  (-poly (b) (-> (-prefab 'hash-state (-HT a b) (-lst a) (-lst b))
+                                 (-values (list B (-> (Un b c))
+                                                (-prefab 'hash-state
+                                                         (-HT a b)
+                                                         (-lst a)
+                                                         (-lst b))))))))]
+[hash-shortcut-step
+ (-poly (a c) (-> a (-> (Un c -Unsafe-Undefined))
+                  (-poly (b) (-> (-HT a b)
+                                 (-values (list B (-> (Un b c))))))))]
+
+[invoke-thunk (-poly (a) (-> (-> a) a))]
+[hash-state-closed? (-poly (a b) (-> (-prefab 'hash-state (-HT a b) (-lst a) (-lst b)) B))]
+[hash-state-residue (-poly (a b) (-> (-prefab 'hash-state (-HT a b) (-lst a) (-lst b)) (-HT a b)))]
+[undef -Unsafe-Undefined]
+[user-def Univ]
+
 ;; Section 10.1
 [values (-polydots (a b) (cl->*
                            (-> (-values null))

diff --git a/typed-racket-test/fail/match-hash-pattern.rkt b/typed-racket-test/fail/match-hash-pattern.rkt
@@ -0,0 +1,5 @@
+#lang typed/racket
+
+(match (hash 1 "2" 3 "4")
+  [(hash* [1 #{x : String} #:default #f] [3 #{y : String}])
+   (list x y)])
diff --git a/typed-racket-test/succeed/match-hash-pattern.rkt b/typed-racket-test/succeed/match-hash-pattern.rkt
@@ -0,0 +1,32 @@
+#lang typed/racket
+
+(match (hash 1 "2" 3 "4")
+  [(hash 1 #{x : String} 3 #{y : String})
+   (list x y)])
+
+(match (hash 1 "2" 3 "4")
+  [(hash* [1 #{x : String}] [3 #{y : String}])
+   (list x y)])
+
+(match (hash 1 "2" 3 "4")
+  [(hash* [1 #{x : (U String Symbol)} #:default 'a] [3 #{y : (U String Boolean)} #:default #t])
+   (list x y)])
+
+(match (hash 1 "2" 3 "4")
+  [(hash* [1 #{x : (U String Symbol)} #:default 'a] [3 #{y : (U String Boolean)} #:default #t] #:closed)
+   (list x y)])
+
+(match (hash 1 "2" 3 "4")
+  [(hash* [1 #{x : (U String False)} #:default #f] [3 #{y : String}])
+   (list x y)])
+
+(match (hash 1 "2" 3 "4")
+  [(hash* [1 #{x : (U String False)} #:default #f]
+          [3 #{y : String}] #:closed)
+   (list x y)])
+
+(match (hash 1 "2" 3 "4")
+  [(hash* [1 #{x : (U String False)} #:default #f]
+          [3 #{y : String}]
+          #:rest #{ht : (HashTable Integer String)})
+   (list x y ht)])