Improve compilation of hash table patterns with literal keys.

racket/collects/racket/match/compiler.rkt

@@ -55,11 +55,15 @@
                                                   (Row-vars-seen row)))
                                       rows)
                                  esc)])
-      #`[(#,predicate-stx #,x) rhs]))
+      (if (procedure? predicate-stx)
+          #`[#,(predicate-stx x) rhs]
+          #`[(#,predicate-stx #,x) rhs])))
   (define (compile-con-pat accs pred pat-acc)
     (with-syntax* ([(tmps ...) (generate-temporaries accs)]
                    [(accs ...) accs]
-                   [pred pred]
+                   [question (if (procedure? pred)
+                                 (pred x)
+                                 #`(#,pred #,x))]
                    [body (compile*
                           (append (syntax->list #'(tmps ...)) xs)
                           (map (lambda (row)
@@ -70,7 +74,7 @@
                                             (Row-vars-seen row)))
                                 rows)
                            esc)])
-      #`[(pred #,x) (let ([tmps (accs #,x)] ...) body)]))
+      #`[question (let ([tmps (accs #,x)] ...) body)]))
   (cond
     [(eq? 'box k)
      (compile-con-pat (list #'unsafe-unbox*) #'box? (compose list Box-p))]
@@ -123,6 +127,7 @@
             [pred (Struct-pred s)])
        (compile-con-pat accs pred Struct-ps))]
     [(syntax? k) (constant-pat k)]
+    [(procedure? k) (constant-pat k)]
     [else (error 'match-compile "bad key: ~a" k)]))
 
 
@@ -256,7 +261,10 @@
             [pats (Row-pats row)]
             [app-pats (App-ps first)])
        (with-syntax ([(t ...) (generate-temporaries app-pats)])
-         #`(let-values ([(t ...) (#,(App-expr first) #,x)])
+         #`(let-values ([(t ...)
+                         #,(if (procedure? (App-expr first))
+                             ((App-expr first) x)
+                             #`(#,(App-expr first) #,x))])
              #,(compile* (append (syntax->list #'(t ...)) xs)
                          (list (make-Row (append app-pats (cdr pats))
                                          (Row-rhs row)

racket/collects/racket/match/parse-helper.rkt

@@ -8,7 +8,7 @@
          "syntax-local-match-introduce.rkt")
 
 (provide ddk? parse-literal all-vars pattern-var? match:syntax-err
-         match-expander-transform trans-match parse-struct
+         match-expander-transform trans-match trans-match* parse-struct
          dd-parse parse-quote parse-id in-splicing?)
 
 (define in-splicing? (make-parameter #f))
@@ -155,6 +155,10 @@
 (define (trans-match pred transformer pat)
   (make-OrderedAnd (list (make-Pred pred) (make-App transformer (list pat)))))
 
+(define (trans-match* preds transformers pats)
+  (make-OrderedAnd (append (map make-Pred preds)
+                           (map (λ (t p) (make-App t (list p))) transformers pats))))
+
 ;; transform a match-expander application
 ;; parse : stx -> pattern
 ;; expander : identifier

racket/collects/racket/match/parse.rkt

@@ -18,6 +18,13 @@
 (define orig-insp (variable-reference->module-declaration-inspector
                    (#%variable-reference)))
 
+(define (literal-pat? p)
+  (syntax-case p ()
+    [(_quote e)
+     (eq? 'quote (syntax-e #'_quote))
+     (parse-literal (syntax-e #'e))]
+    [_ (parse-literal (syntax-e p))]))
+
 ;; parse : syntax -> Pat
 ;; compile stx into a pattern, using the new syntax
 (define (parse stx)
@@ -88,6 +95,13 @@
      (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 p ...)
      (trans-match #'hash?
                   #'(lambda (e) (hash-map e list))

racket/collects/racket/match/patterns.rkt

@@ -49,16 +49,17 @@
 ;; (define-struct (Boolean Atom) () #:transparent)
 (define-struct (Null CPat) (p) #:transparent)
 
-;; expr is an expression
+;; expr is an expression or an (expression -> expression) procedure
 ;; ps is a list of patterns
 (define-struct (App Pat) (expr ps) #:transparent)
 
-;; pred is an expression
+;; pred is an expression, or an Expr -> Expr procedure
 (define-struct (Pred Pat) (pred) #:transparent
   #:property prop:equal+hash
   (list (lambda (a b e?)
+          (or (eq? (Pred-pred a) (Pred-pred b))
               (and (identifier? (Pred-pred a)) (identifier? (Pred-pred b))
-               (free-identifier=? (Pred-pred a) (Pred-pred b))))
+                   (free-identifier=? (Pred-pred a) (Pred-pred b)))))
         (lambda (v r)
           (if (identifier? (Pred-pred v))
               (r (syntax-e (Pred-pred v)))
@@ -75,9 +76,6 @@
 ;; ps is a listof patterns
 (define-struct (Struct CPat) (id pred super complete? accessors ps) #:transparent)
 
-;; both fields are lists of pats
-(define-struct (HashTable CPat) (key-pats val-pats) #:transparent)
-
 ;; ps are patterns
 (define-struct (Or Pat) (ps) #:transparent)
 (define-struct (And Pat) (ps) #:transparent)