Improves error for references to not-yet-defined metafunctions

Fixes PR 11041

collects/redex/private/error.rkt

@@ -1,8 +1,12 @@
 #lang scheme/base
 (define-struct (exn:fail:redex exn:fail) ())
 (define (redex-error name fmt . args)
-  (let ([str (format "~a: ~a" name (apply format fmt args))])
+  (define suffix (apply format fmt args))
-    (raise (make-exn:fail:redex str (current-continuation-marks)))))
+  (define message
+    (if name
+        (format "~a: ~a" name suffix)
+        suffix))
+  (raise (make-exn:fail:redex message (current-continuation-marks))))
 (provide redex-error
          exn:fail:redex?
          (struct-out exn:fail:redex))

collects/redex/private/term.rkt

@@ -2,7 +2,9 @@
 
 (require (for-syntax scheme/base 
                      "term-fn.ss"
+                     syntax/boundmap
                      racket/syntax)
+         "error.rkt"
          "matcher.ss")
 
 (provide term term-let term-let/error-name term-let-fn term-define-fn hole in-hole)
@@ -15,13 +17,13 @@
     [(_ () e) (syntax e)]
     [(_ (a b ...) e) (syntax (with-syntax (a) (with-syntax* (b ...) e)))]))
 
-(define-syntax (term stx)
+(define-syntax-rule (term t)
-  (syntax-case stx ()
+  (#%expression (term/private t)))
-    [(_ arg)
-    #`(term/private arg)]))
 
 (define-syntax (term/private orig-stx)
   (define outer-bindings '())
+  (define applied-metafunctions
+    (make-free-identifier-mapping))
   
   (define (rewrite stx)
     (let-values ([(rewritten _) (rewrite/max-depth stx 0)])
@@ -54,9 +56,9 @@
       [(metafunc-name arg ...)
        (and (identifier? (syntax metafunc-name))
             (term-fn? (syntax-local-value (syntax metafunc-name) (λ () #f))))
-       (rewrite-application (term-fn-get-id (syntax-local-value/record (syntax metafunc-name) (λ (x) #t)))
+       (let ([f (term-fn-get-id (syntax-local-value/record (syntax metafunc-name) (λ (x) #t)))])
-                            (syntax/loc stx (arg ...))
+         (free-identifier-mapping-put! applied-metafunctions f #t)
-                            depth)]
+         (rewrite-application f (syntax/loc stx (arg ...)) depth))]
       [f
        (and (identifier? (syntax f))
             (term-fn? (syntax-local-value (syntax f) (λ () #f))))
@@ -110,13 +112,32 @@
     [(_ arg)
      (with-disappeared-uses
       (with-syntax ([rewritten (rewrite (syntax arg))])
-        (let loop ([bs (reverse outer-bindings)])
+        #`(begin
-          (cond
+            #,@(free-identifier-mapping-map
-            [(null? bs) (syntax (syntax->datum (quasisyntax rewritten)))]
+                applied-metafunctions
-            [else (with-syntax ([rec (loop (cdr bs))]
+                (λ (f _)
-                                [fst (car bs)])
+                  (if (eq? (identifier-binding f) 'lexical)
-                    (syntax (with-syntax (fst)
+                      #`(check-defined-lexical #,f '#,f)
-                              rec)))]))))]))
+                      #`(check-defined-module (λ () #,f) '#,f))))
+            #,(let loop ([bs (reverse outer-bindings)])
+                (cond
+                  [(null? bs) (syntax (syntax->datum (quasisyntax rewritten)))]
+                  [else (with-syntax ([rec (loop (cdr bs))]
+                                      [fst (car bs)])
+                          (syntax (with-syntax (fst)
+                                    rec)))])))))]))
+
+(define (check-defined-lexical value name)
+  (when (eq? (letrec ([x x]) x) value)
+    (report-undefined-metafunction name)))
+
+(define (check-defined-module thunk name)
+  (with-handlers ([exn:fail:contract:variable?
+                   (λ (_) (report-undefined-metafunction name))])
+    (thunk)))
+
+(define (report-undefined-metafunction name)
+  (redex-error #f "metafunction ~s applied before its definition" name))
 
 (define-syntax (term-let-fn stx)
   (syntax-case stx ()
@@ -131,7 +152,7 @@
 (define-syntax (term-define-fn stx)
   (syntax-case stx ()
     [(_ id exp)
-     (with-syntax ([(id2) (generate-temporaries (syntax (id)))])
+     (with-syntax ([id2 (datum->syntax #'here (syntax-e #'id))])
        (syntax
         (begin
           (define id2 exp)

collects/redex/tests/tl-test.rkt

@@ -1,4 +1,4 @@
-#lang racket
+#lang racket/gui
   (require "../reduction-semantics.ss"
            "test-util.ss"
            (only-in "../private/matcher.ss" make-bindings make-bind)
@@ -7,6 +7,7 @@
   
   (reset-count)
 
+  (define-namespace-anchor this-namespace)
   (parameterize ([current-namespace syn-err-test-namespace])
     (eval (quote-syntax
            (define-language grammar
@@ -994,6 +995,27 @@
                  x)
           '(2 1)))
   
+  ;; errors for not-yet-defined metafunctions
+  (test (parameterize ([current-namespace (make-empty-namespace)])
+          (namespace-attach-module (namespace-anchor->namespace this-namespace) 'racket/gui)
+          (namespace-attach-module (namespace-anchor->namespace this-namespace) 'redex/reduction-semantics)
+          (namespace-require 'racket)
+          (eval '(module m racket
+                   (require redex)
+                   (term (q))
+                   (define-language L)
+                   (define-metafunction L [(q) ()])))
+          (with-handlers ([exn:fail:redex? exn-message])
+            (eval '(require 'm))
+            #f))
+        "metafunction q applied before its definition")
+  (test (with-handlers ([exn:fail:redex? exn-message])
+          (let ()
+            (term (q))
+            (define-language L)
+            (define-metafunction L [(q) ()])
+            #f))
+        "metafunction q applied before its definition")
   
   (let ()
     (test-syn-err