From 393582492203608a579a062b3fcece0ad4e18e88 Mon Sep 17 00:00:00 2001
From: Justin Slepak <jrslepak@users.noreply.github.com>
Date: Thu, 12 Oct 2017 01:11:00 -0400
Subject: [PATCH] Fix bug in hash-table key-value match pattern (#1532)

Match pattern allowed `(hash-table)' to match on non-empty hashes
---
 pkgs/racket-test/tests/match/examples.rkt        |  9 +++++++++
 pkgs/racket-test/tests/match/match-tests.rkt     |  5 +++++
 pkgs/racket-test/tests/match/other-plt-tests.rkt |  8 ++++++++
 racket/collects/racket/match/parse.rkt           | 16 +++++++++-------
 4 files changed, 31 insertions(+), 7 deletions(-)

diff --git a/pkgs/racket-test/tests/match/examples.rkt b/pkgs/racket-test/tests/match/examples.rkt
index b91f021445..d0df54b4bc 100644
--- a/pkgs/racket-test/tests/match/examples.rkt
+++ b/pkgs/racket-test/tests/match/examples.rkt
@@ -357,6 +357,15 @@
                    [(hash-table (key val) ...) key]
                    [_ 'no])))
 
+   (comp "non-empty"
+         (match #hash((1 . 2))
+           [(hash-table) "empty"]
+           [_ "non-empty"]))
+   (comp "empty"
+         (match #hash()
+           [(hash-table) "empty"]
+           [_ "non-empty"]))
+
    (comp
     (match #(1 (2) (2) (2) 5)
       [(vector 1 (list a) ..3 5) a]
diff --git a/pkgs/racket-test/tests/match/match-tests.rkt b/pkgs/racket-test/tests/match/match-tests.rkt
index c72a5b3b7f..8863c7f7ab 100644
--- a/pkgs/racket-test/tests/match/match-tests.rkt
+++ b/pkgs/racket-test/tests/match/match-tests.rkt
@@ -40,6 +40,11 @@
                            (else #f)))
                        (check-true (origin? (make-point 0 0)))
                        (check-false (origin? (make-point 1 1)))))
+     (test-case "empty hash-table pattern bug"
+                (check string=? "non-empty"
+                       (match #hash((1 . 2))
+                         [(hash-table) "empty"]
+                         [_ "non-empty"])))
      ))
   
   (define nonlinear-tests
diff --git a/pkgs/racket-test/tests/match/other-plt-tests.rkt b/pkgs/racket-test/tests/match/other-plt-tests.rkt
index 57ae43a31f..c09e3eff3c 100644
--- a/pkgs/racket-test/tests/match/other-plt-tests.rkt
+++ b/pkgs/racket-test/tests/match/other-plt-tests.rkt
@@ -320,6 +320,14 @@
      (mytest (match (hash-table)
                ((hash-table) 5))
              5)
+     (mytest (match #hash((1 . 2))
+           [(hash-table) "empty"]
+           [_ "non-empty"])
+             "non-empty")
+     (mytest (match #hash()
+           [(hash-table) "empty"]
+           [_ "non-empty"])
+             "empty")
      
      ; These cases work but I need a better way of testing them.
      ; (mytest (match (hash-table ('a "hey") ('b "sup") ('c "sup") ('d "sup") ('e "down") ('f "dat"))
diff --git a/racket/collects/racket/match/parse.rkt b/racket/collects/racket/match/parse.rkt
index 07e0546902..59572ee218 100644
--- a/racket/collects/racket/match/parse.rkt
+++ b/racket/collects/racket/match/parse.rkt
@@ -95,13 +95,15 @@
      (raise-syntax-error
       'match "dot dot k can only appear at the end of hash-table patterns" stx
       (ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]
-    [(hash-table (k v) ...)
-     (andmap (λ (p) (and (literal-pat? p) (not (identifier? p)))) (syntax->list #'(k ...)))
-     (let ([keys (map Exact-v (map literal-pat? (syntax->list #'(k ...))))])
-       (trans-match*
-        (cons #'hash? (for/list ([k (in-list keys)]) (λ (e) #`(hash-has-key? #,e '#,k))))
-        (for/list ([k (in-list keys)]) (λ (e) #`(hash-ref #,e '#,k)))
-        (map parse (syntax->list #'(v ...)))))]
+    [(hash-table (k0 v0) (k1 v1) ...)
+     (andmap (λ (p) (and (literal-pat? p) (not (identifier? p)))) (syntax->list #'(k0 k1 ...)))
+     (with-syntax ([(k ...) #'(k0 k1 ...)]
+                   [(v ...) #'(v0 v1 ...)])
+       (let ([keys (map Exact-v (map literal-pat? (syntax->list #'(k ...))))])
+         (trans-match*
+          (cons #'hash? (for/list ([k (in-list keys)]) (λ (e) #`(hash-has-key? #,e '#,k))))
+          (for/list ([k (in-list keys)]) (λ (e) #`(hash-ref #,e '#,k)))
+          (map parse (syntax->list #'(v ...))))))]
     [(hash-table p ...)
      (trans-match #'hash?
                   #'(lambda (e) (hash-map e list))