From 12df86ee74e554bcb633f34faa5541744b6eb7cb Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonyg@leastfixedpoint.com>
Date: Thu, 3 Jun 2021 22:42:42 +0200
Subject: [PATCH] Hash-table patterns

---
 syndicate/pattern.rkt | 26 ++++++++++++++++++++++++++
 1 file changed, 26 insertions(+)

diff --git a/syndicate/pattern.rkt b/syndicate/pattern.rkt
index 12152d6..0076bb6 100644
--- a/syndicate/pattern.rkt
+++ b/syndicate/pattern.rkt
@@ -84,6 +84,11 @@
     (and (identifier? stx)
          (free-identifier=? #'list stx)))
 
+  (define (hash-or-hasheqv-id? stx)
+    (and (identifier? stx)
+         (or (free-identifier=? #'hash stx)
+             (free-identifier=? #'hasheqv stx))))
+
   (define (constructor-registered? stx)
     (free-id-table-ref preserves-pattern-registry stx #f))
 
@@ -106,6 +111,12 @@
     (values (syntax-e ctor-stx)
             expected-count))
 
+  (define (append-map-pairs f xs)
+    (match xs
+      ['() '()]
+      [(list _) (raise-syntax-error #f "Odd number of elements in hash-like pattern")]
+      [(list* k v more) (append (f k v) (append-map-pairs f more))]))
+
   (define (analyse-pattern stx)
     (define disarmed-stx (syntax-disarm stx orig-insp))
     (syntax-case disarmed-stx ($ quasiquote unquote quote)
@@ -144,6 +155,12 @@
                                                  (piece (in-list (syntax->list #'(piece ...))))]
                                         (member-entry n piece))))))]
 
+      [(hash-stx piece ...)
+       (hash-or-hasheqv-id? #'hash-stx)
+       #`(Pattern-DCompound
+          (DCompound-dict (CDict)
+                          (hash #,@(append-map-pairs member-entry (syntax->list #'(piece ...))))))]
+
       [id
        (dollar-id? #'id)
        #`(Pattern-DBind (DBind '#,(undollar #'id) (Pattern-DDiscard (DDiscard))))]
@@ -185,6 +202,10 @@
        (list-id? #'list-stx)
        (append-map analyse-pattern-bindings (syntax->list #'(piece ...)))]
 
+      [(hash-stx piece ...)
+       (hash-or-hasheqv-id? #'hash-stx)
+       (append-map-pairs (lambda (_k v) (analyse-pattern-bindings v)) (syntax->list #'(piece ...)))]
+
       [id
        (dollar-id? #'id)
        (list (undollar #'id))]
@@ -219,6 +240,11 @@
        (list-id? #'list-stx)
        #`(list-stx #,@(map analyse-template (syntax->list #'(piece ...))))]
 
+      [(hash-stx piece ...)
+       (hash-or-hasheqv-id? #'hash-stx)
+       #`(hash-stx #,@(append-map-pairs (lambda (k v) (list k (analyse-template v)))
+                                        (syntax->list #'(piece ...))))]
+
       [other #'other])))
 
 (define-syntax (:pattern stx)