From 10a8a625fae5feb185060c3f37dd50cc6be21c3e Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 27 Oct 2012 20:37:43 -0500
Subject: [PATCH] record the (uncompiled) domain pattern with a reduction
 relation so that context-closure can adjust the domain

closes PR 13204
---
 collects/redex/private/reduction-semantics.rkt | 15 +++++++++++++--
 collects/redex/private/struct.rkt              | 12 +++++++-----
 collects/redex/tests/tl-test.rkt               | 11 +++++++++++
 3 files changed, 31 insertions(+), 7 deletions(-)

diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt
index 5649703c66..edbcb74af1 100644
--- a/collects/redex/private/reduction-semantics.rkt
+++ b/collects/redex/private/reduction-semantics.rkt
@@ -202,7 +202,16 @@
       (reduction-relation-make-procs red))
      (reduction-relation-rule-names red)
      (reduction-relation-lws red)
-     `any)))
+     (let ([orig-pat (reduction-relation-domain-pat red)])
+       (cond
+         [(equal? orig-pat `any)
+          ;; special case for backwards compatibility:
+          ;; if there was no #:domain argument, then we
+          ;; probably should let the compatible closure also
+          ;; not have a domain
+          `any]
+         [else
+          `(in-hole ,pat ,orig-pat)])))))
 
 (define (apply-reduction-relation/tagged p v)
   (let loop ([procs (reduction-relation-procs p)]
@@ -941,7 +950,9 @@
      (reverse (apply append (map reduction-relation-make-procs lst)))
      (map car (sort (hash-map name-ht list) < #:key cadr))
      (apply append (map reduction-relation-lws lst)) 
-     (reverse (apply append (map reduction-relation-procs lst))))))
+     (reverse (apply append (map reduction-relation-procs lst)))
+     ;; not clear what the contract is here.
+     `any)))
 
 (define (do-node-match lhs-frm-id lhs-to-id pat rhs-proc child-make-proc rhs-from)
   (define (subst from to in)
diff --git a/collects/redex/private/struct.rkt b/collects/redex/private/struct.rkt
index 6fb89c6340..b449ab5acb 100644
--- a/collects/redex/private/struct.rkt
+++ b/collects/redex/private/struct.rkt
@@ -8,6 +8,7 @@
          reduction-relation-rule-names
          reduction-relation-lws
          reduction-relation-procs
+         reduction-relation-domain-pat
          build-reduction-relation make-reduction-relation
          reduction-relation?
          empty-reduction-relation
@@ -40,13 +41,14 @@
 ;; make-procs = (listof (compiled-lang -> proc))
 ;; rule-names : (listof sym)
 ;; procs : (listof proc)
-(define-struct reduction-relation (lang make-procs rule-names lws procs))
+(define-struct reduction-relation (lang make-procs rule-names lws procs domain-pat))
 
 (define empty-reduction-relation (make-reduction-relation 'empty-reduction-relations-language
                                                           '()
                                                           '()
                                                           '()
-                                                          '()))
+                                                          '()
+                                                          #f))
 
 (define (build-reduction-relation original language rules rule-names lws domain)
   (define combined-rules
@@ -62,8 +64,7 @@
     (if original
         (remove-duplicates (append rule-names (reduction-relation-rule-names original)))
         rule-names))
-  (define compiled-domain
-    (compile-pattern language domain #f))
+  (define compiled-domain (compile-pattern language domain #f))
   (make-reduction-relation
    language combined-rules combined-rule-names lws
    (map (λ (rule)
@@ -81,4 +82,5 @@
             (unless (match-pattern compiled-domain exp)
               (error 'reduction-relation "relation not defined for ~s" exp))
             (specialized exp exp checked-rewrite acc)))
-        combined-rules)))
+        combined-rules)
+   domain))
diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt
index d848fdbe13..cbf2c0f620 100644
--- a/collects/redex/tests/tl-test.rkt
+++ b/collects/redex/tests/tl-test.rkt
@@ -1722,6 +1722,17 @@
          '(4 2))
         (list '8))
   
+  (test (with-handlers ((exn:fail? exn-message))
+          (apply-reduction-relation
+           (context-closure 
+            (reduction-relation
+             empty-language #:domain #f
+             (--> #f #f))
+            empty-language hole)
+           #t)
+          "exn not raised")
+        #rx"^reduction-relation:")
+  
   (test (apply-reduction-relation
          (context-closure 
           (context-closure