From 639ceae231a8f6724fa0c0658c68bb6834f6a368 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonyg@leastfixedpoint.com>
Date: Mon, 2 Jan 2023 11:20:00 +0100
Subject: [PATCH] instantiate-pattern

---
 syndicate/pattern.rkt | 47 ++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 42 insertions(+), 5 deletions(-)

diff --git a/syndicate/pattern.rkt b/syndicate/pattern.rkt
index 0a7d636..04d6f7b 100644
--- a/syndicate/pattern.rkt
+++ b/syndicate/pattern.rkt
@@ -7,6 +7,7 @@
                      register-preserves-pattern!
                      analyse-pattern
                      analyse-pattern-bindings
+                     instantiate-pattern
                      analyse-match-pattern)
          define-preserves-pattern
          :pattern
@@ -137,12 +138,13 @@
   (define (transform-binding id-stx expanded-stx)
     ((syntax-parameter-value #'transform-pattern-binding) id-stx expanded-stx))
 
+  (define (walk-hash walk pieces-stx)
+    (append-map-pairs (lambda (key-stx pat-stx) (list key-stx (walk pat-stx)))
+                      (syntax->list pieces-stx)))
+
   (define (analyse-pattern stx
                            #:check-destructuring [check-destructuring (lambda (stx) stx)]
                            #:wrap-literal [wrap-literal (lambda (stx) stx)])
-    (define (walk-hash pieces-stx)
-      (append-map-pairs (lambda (key-stx pat-stx) (list key-stx (walk pat-stx)))
-                        (syntax->list pieces-stx)))
     (define (walk stx)
       (define disarmed-stx (syntax-disarm stx orig-insp))
       (syntax-case disarmed-stx ($ quasiquote unquote quote)
@@ -174,7 +176,7 @@
 
         [(hash-stx piece ...)
          (hash-or-hasheqv-id? #'hash-stx)
-         (check-destructuring #`(dict (hash #,@(walk-hash #'(piece ...)))))]
+         (check-destructuring #`(dict (hash #,@(walk-hash walk #'(piece ...)))))]
 
         [id
          (dollar-id? #'id)
@@ -200,7 +202,7 @@
         [(c (hash-stx piece ...))
          (and (id=? #'dict #'c)
               (hash-or-hasheqv-id? #'hash-stx))
-         #`(dict* (hash-stx #,@(walk-hash #'(piece ...))))]
+         #`(dict* (hash-stx #,@(walk-hash walk #'(piece ...))))]
 
         [other #`(literal->literal-pattern #,(wrap-literal #'other))]))
     (walk stx))
@@ -264,6 +266,41 @@
 
         [other '()])))
 
+  (define (instantiate-pattern stx lookup)
+    (let walk ((stx stx))
+      (define disarmed-stx (syntax-disarm stx orig-insp))
+      (syntax-case disarmed-stx ($ quasiquote unquote quote)
+        [expander
+         (pattern-expander-form? #'expander)
+         (pattern-expander-transform disarmed-stx
+                                     (lambda (result) (walk (syntax-rearm result stx))))]
+
+        ;; Extremely limited support for quasiquoting and quoting
+        [(quasiquote (unquote p)) (walk #'p)]
+        [(quasiquote (p ...)) (walk #'(list (quasiquote p) ...))]
+        [(quasiquote _p) '()]
+        [(quote _p) '()]
+
+        [(hash-stx piece ...)
+         (hash-or-hasheqv-id? #'hash-stx)
+         (quasisyntax/loc stx (hash-stx #,@(walk-hash walk #'(piece ...))))]
+
+        [id
+         (dollar-id? #'id)
+         (lookup (undollar #'id) #f)]
+
+        [($ id p)
+         (lookup #'id (lambda () (walk #'p)))]
+
+        [id
+         (discard-id? #'id)
+         (raise-syntax-error 'instantiate-pattern "Cannot instantiate discard patterns" stx)]
+
+        [(f args ...)
+         (quasisyntax/loc stx (f #,@(map walk (syntax->list #'(args ...)))))]
+
+        [other #'other])))
+
   (define (analyse-match-pattern stx)
     (let walk ((stx stx))
       (define disarmed-stx (syntax-disarm stx orig-insp))