From daba892a07a11d00503f6f9245575221a1390ee7 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Fri, 4 May 2018 17:52:16 +0100
Subject: [PATCH] pattern-expander.rkt

---
 syndicate/pattern-expander.rkt  | 23 ++++++++++++++++++++++
 syndicate/pattern.rkt           | 35 +++++++++++++++++++++++++++++----
 syndicate/test/pattern-test.rkt | 14 +++++++++++++
 3 files changed, 68 insertions(+), 4 deletions(-)
 create mode 100644 syndicate/pattern-expander.rkt

diff --git a/syndicate/pattern-expander.rkt b/syndicate/pattern-expander.rkt
new file mode 100644
index 0000000..dfd1c4d
--- /dev/null
+++ b/syndicate/pattern-expander.rkt
@@ -0,0 +1,23 @@
+#lang racket/base
+
+(require auxiliary-macro-context)
+
+(define-auxiliary-macro-context
+  #:context-name pattern-expander
+  #:prop-name prop:pattern-expander
+  #:prop-predicate-name pattern-expander?
+  #:prop-accessor-name pattern-expander-proc
+  #:macro-definer-name define-pattern-expander
+  #:introducer-parameter-name current-pattern-expander-introducer
+  #:local-introduce-name syntax-local-pattern-expander-introduce
+  #:expander-id-predicate-name pattern-expander-id?
+  #:expander-transform-name pattern-expander-transform)
+
+(provide (for-syntax
+          prop:pattern-expander
+          pattern-expander?
+          pattern-expander-proc
+          syntax-local-pattern-expander-introduce
+          pattern-expander-id?
+          pattern-expander-transform)
+         define-pattern-expander)
diff --git a/syndicate/pattern.rkt b/syndicate/pattern.rkt
index 4f6910e..13f3fd4 100644
--- a/syndicate/pattern.rkt
+++ b/syndicate/pattern.rkt
@@ -11,12 +11,15 @@
                      desc->skeleton-stx
                      desc->capture-proj
                      desc->capture-names
-                     desc->assertion-stx))
+                     desc->assertion-stx)
+
+         (all-from-out "pattern-expander.rkt"))
 
 (require (for-syntax racket/base))
 (require (for-syntax racket/match))
 (require (for-syntax racket/struct-info))
 (require (for-syntax syntax/stx))
+(require "pattern-expander.rkt")
 
 (struct discard () #:prefab)
 (struct capture (detail) #:prefab)
@@ -35,6 +38,9 @@
 ;; The other `SkProj` generates a second `SkKey` which is used as the
 ;; input to a handler function.
 
+(define-for-syntax orig-insp
+  (variable-reference->module-declaration-inspector (#%variable-reference)))
+
 (begin-for-syntax
   (define (dollar-id? stx)
     (and (identifier? stx)
@@ -61,7 +67,14 @@
          (free-identifier=? #'vector stx)))
 
   (define (analyse-pattern stx)
-    (syntax-case stx ($ quasiquote unquote quote)
+    (define disarmed-stx (syntax-disarm stx orig-insp))
+    (syntax-case disarmed-stx ($ quasiquote unquote quote)
+      [(expander args ...)
+       (pattern-expander-id? #'expander)
+       (pattern-expander-transform disarmed-stx
+                                   (lambda (result)
+                                     (analyse-pattern (syntax-rearm result stx))))]
+
       ;; Extremely limited support for quasiquoting and quoting
       [(quasiquote (unquote p)) (analyse-pattern #'p)]
       [(quasiquote (p ...)) (analyse-pattern #'(list (quasiquote p) ...))]
@@ -95,7 +108,14 @@
        (list 'atom stx)]))
 
   (define (instantiate-pattern->pattern stx)
-    (syntax-case stx ($ quasiquote unquote quote)
+    (define disarmed-stx (syntax-disarm stx orig-insp))
+    (syntax-case disarmed-stx ($ quasiquote unquote quote)
+      [(expander args ...)
+       (pattern-expander-id? #'expander)
+       (pattern-expander-transform disarmed-stx
+                                   (lambda (result)
+                                     (instantiate-pattern->pattern (syntax-rearm result stx))))]
+
       ;; Extremely limited support for quasiquoting and quoting
       [(quasiquote (unquote p)) (instantiate-pattern->pattern #'p)]
       [(quasiquote (p ...)) (instantiate-pattern->pattern #'(list (quasiquote p) ...))]
@@ -123,7 +143,14 @@
        #'other]))
 
   (define (instantiate-pattern->value stx)
-    (syntax-case stx ($ quasiquote unquote quote)
+    (define disarmed-stx (syntax-disarm stx orig-insp))
+    (syntax-case disarmed-stx ($ quasiquote unquote quote)
+      [(expander args ...)
+       (pattern-expander-id? #'expander)
+       (pattern-expander-transform disarmed-stx
+                                   (lambda (result)
+                                     (instantiate-pattern->value (syntax-rearm result stx))))]
+
       ;; Extremely limited support for quasiquoting and quoting
       [(quasiquote (unquote p)) (instantiate-pattern->pattern #'p)]
       [(quasiquote (p ...)) (instantiate-pattern->pattern #'(list (quasiquote p) ...))]
diff --git a/syndicate/test/pattern-test.rkt b/syndicate/test/pattern-test.rkt
index 93591a7..25d4135 100644
--- a/syndicate/test/pattern-test.rkt
+++ b/syndicate/test/pattern-test.rkt
@@ -51,4 +51,18 @@
                          (foo (bar 'beep) $cap)
                          (s->d desc->assertion-stx))
 
+  (define-pattern-expander foo123
+    (syntax-rules ()
+      [(_ zot) (foo 123 zot)]))
+
+  (define-pattern-expander foo234
+    (syntax-rules ()
+      [(_ zot) (foo 234 zot)])
+    (syntax-rules ()
+      [(_ zot) (foo 234 zot)]))
+
+  (check-analyse-pattern '(foo 123 'zot) (foo123 'zot))
+  (check-analyse-pattern '(foo 234 'zot) (foo234 'zot))
+  (check-equal? (foo 234 'zot) (foo234 'zot))
+
   )