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

@@ -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)

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))

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