From dfab2a25bffee96c8c67e5c500cae6a9df21c425 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Fri, 22 Apr 2016 18:48:43 -0700
Subject: [PATCH] implement `caller-stx` parameter

---
 beautiful-racket-lib/br/define.rkt | 19 +++++++++++++++++--
 beautiful-racket-lib/br/main.rkt   |  1 +
 2 files changed, 18 insertions(+), 2 deletions(-)

diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt
index aae6578..09c3de8 100644
--- a/beautiful-racket-lib/br/define.rkt
+++ b/beautiful-racket-lib/br/define.rkt
@@ -14,6 +14,12 @@
                                  (regexp-match #rx"^_" str)))))
              pat-arg))
 
+;; expose the caller context within br:define macros with syntax parameter
+(begin-for-syntax
+  (require (for-syntax racket/base) racket/stxparam)
+  (provide caller-stx)
+  (define-syntax-parameter caller-stx (λ(stx) (error 'not-parameterized))))
+
 ;; todo: support `else` case
 (define-syntax (br:define-cases stx)
   (define-syntax-class syntaxed-id
@@ -43,7 +49,8 @@
        #'(define-syntax top-id.name (λ (stx)
                                       (define result
                                         (syntax-case stx (LITERAL ...)
-                                          [pat body ...] ...
+                                          [pat (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
+                                                 body ...)] ...
                                           [else (raise-syntax-error 'define-cases (format "no matching case for syntax pattern `~a`" (syntax->datum stx)) (syntax->datum #'top-id.name))]))
                                       (if (not (syntax? result))
                                           (datum->syntax stx result)
@@ -144,7 +151,15 @@
   (begin
     (br:define #'(redefine _id) #'(define _id 42))
     (redefine zoombar)
-    (check-equal? zoombar 42)))
+    (check-equal? zoombar 42))
+
+  ;; use caller-stx parameter to introduce identifier unhygienically
+  (br:define #'(zam _arg1 _arg2 _arg3)
+    (with-syntax ([dz (datum->syntax caller-stx 'dirty-zam)])
+      #`(define dz 'got-dirty-zam)))
+  
+  (zam 'this 'that 42)
+  (check-equal? dirty-zam 'got-dirty-zam))
 
 
 (define-syntax-rule (br:debug-define (syntax (id pat-arg ... . rest-arg)) body-exp)
diff --git a/beautiful-racket-lib/br/main.rkt b/beautiful-racket-lib/br/main.rkt
index 9ab9ab9..e597dfc 100644
--- a/beautiful-racket-lib/br/main.rkt
+++ b/beautiful-racket-lib/br/main.rkt
@@ -6,6 +6,7 @@
          (all-from-out racket/list racket/string racket/format racket/match racket/port
                        br/syntax br/datum br/debug br/conditional)
          (for-syntax (all-from-out racket/base racket/syntax br/syntax))
+         (for-syntax caller-stx) ; from br/define
          (filtered-out
           (λ (name)
             (let ([pat (regexp "^br:")])