Adds a form like term-let but using Redex patterns

collects/redex/private/reduction-semantics.rkt

@@ -82,22 +82,74 @@
            '())))
    cps rhss))
 
-(define ((term-match/single/proc form-name lang ps cps rhss) term)
+(define ((term-match/single/proc form-name lang ps0 cps rhss) term)
-  (let loop ([ps ps] [cps cps] [rhss rhss])
+  (let loop ([ps ps0] [cps cps] [rhss rhss])
     (if (null? ps)
-        (redex-error form-name "no patterns matched ~e" term)
+        (redex-error form-name 
+                     (if (null? (cdr ps0))
+                         (format "term ~s does not match pattern ~s" term (car ps0))
+                         (format "no patterns matched ~s" term)))
         (let ([match (match-pattern (car cps) term)])
           (if match
               (begin
                 (unless (null? (cdr match))
                   (redex-error
                    form-name
-                   "pattern ~s matched term ~e multiple ways"
+                   "pattern ~s matched term ~s multiple ways"
                    (car ps)
                    term))
                 ((car rhss) (car match)))
               (loop (cdr ps) (cdr cps) (cdr rhss)))))))
 
+(define-syntaxes (redex-let redex-let*)
+  (let ()
+    (define-syntax-class binding
+      #:description "binding clause"
+      (pattern (lhs:expr rhs:expr)))
+    (define-syntax-class (bindings extract)
+      #:description (if extract
+                        "sequence of disjoint binding clauses"
+                        "sequence of binding clauses")
+      (pattern (b:binding ...)
+               #:fail-when (and extract
+                                (check-duplicate-identifier
+                                 (apply append (map extract (syntax->list #'(b.lhs ...))))))
+               "duplicate pattern variable"
+               #:with (lhs ...) #'(b.lhs ...)
+               #:with (rhs ...) #'(b.rhs ...)))
+    
+    (define (redex-let stx)
+      (define-values (form-name nts)
+        (syntax-case stx ()
+          [(name lang . _) 
+           (values (syntax-e #'name)
+                   (language-id-nts #'lang (syntax-e #'name)))]))
+      (define (pattern-variables pattern)
+        (let-values ([(names _) (extract-names nts form-name #t pattern)])
+          names))
+      (syntax-parse stx
+        [(name lang (~var bs (bindings pattern-variables)) body ...+)
+         (with-syntax ([(t ...) (generate-temporaries #'bs)])
+           #`(let ([t bs.rhs] ...)
+               #,(nested-lets #'lang #'([bs.lhs t] ...) #'(body ...) #'name)))]))
+    
+    (define (redex-let* stx)
+      (syntax-parse stx
+        [(name lang (~var bs (bindings #f)) body ...+)
+         (nested-lets #'lang #'bs #'(body ...) #'name)]))
+    
+    (define (nested-lets lang bindings bodies name)
+      (syntax-case bindings ()
+        [()
+         #`(let () #,@bodies)]
+        [([lhs rhs] . bindings)
+         (with-syntax ([rest-lets (nested-lets lang #'bindings bodies name)])
+           #`(#,(term-matcher #`(#,name #,lang [lhs rest-lets]) 
+                              #'term-match/single/proc) 
+              rhs))]))
+    
+    (values redex-let redex-let*)))
+
 (define-syntax (compatible-closure stx)
   (syntax-case stx ()
     [(_ red lang nt)
@@ -2340,6 +2392,8 @@
 (provide test-match
          term-match
          term-match/single
+         redex-let 
+         redex-let*
          make-bindings bindings-table bindings?
          match? match-bindings
          make-bind bind? bind-name bind-exp

collects/redex/redex.scrbl

@@ -508,10 +508,26 @@ present, the pattern before the ellipses may match multiple adjacent
 elements in the list value (possibly none).
 
 This form is a lower-level form in Redex, and not really designed to
-be used directly. If you want a @racket[let]-like form that uses
+be used directly. For @racket[let]-like forms that use
-Redex's full pattern matching facilities, see @racket[term-match] and
+Redex's full pattern matching facilities, see @racket[redex-let],
-@racket[term-match/single].
+@racket[redex-let*], @racket[term-match], @racket[term-match/single].
+}
 
+@defform[(redex-let language ([@#,ttpattern expression] ...) body ...+)]{
+Like @racket[term-let] but the left-hand sides are Redex patterns, 
+interpreted according to the specified language. It is a syntax
+error for two left-hand sides to bind the same pattern variable.
+
+This form raises an exception recognized by @racket[exn:fail:redex?] 
+if any right-hand side does not match its left-hand side in exactly one 
+way. 
+
+In some contexts, it may be more efficient to use @racket[term-match/single]
+(lifted out of the context).
+}
+
+@defform[(redex-let* language ([@#,ttpattern expression] ...) body ...+)]{
+The @racket[let*] analog of @racket[redex-let].
 }
 
 @defform[(term-match language [@#,ttpattern expression] ...)]{

collects/redex/reduction-semantics.rkt

@@ -37,6 +37,8 @@
 (provide (rename-out [test-match redex-match])
          term-match
          term-match/single
+         redex-let
+         redex-let*
          match? match-bindings
          make-bind bind? bind-name bind-exp
          

collects/redex/tests/tl-test.rkt

@@ -1933,6 +1933,58 @@
              (--> r p x))))
         '(a b c z y x))
   
+  
+    ;                                                                 
+    ;                                                                 
+    ;                    ;;                        ;;                 
+    ;                     ;                         ;            ;    
+    ;   ;; ;;   ;;;    ;; ;   ;;;  ;;  ;;           ;     ;;;   ;;;;; 
+    ;    ;;    ;   ;  ;  ;;  ;   ;  ;  ;            ;    ;   ;   ;    
+    ;    ;     ;;;;;  ;   ;  ;;;;;   ;;    ;;;;;    ;    ;;;;;   ;    
+    ;    ;     ;      ;   ;  ;       ;;             ;    ;       ;    
+    ;    ;     ;      ;   ;  ;      ;  ;            ;    ;       ;   ;
+    ;   ;;;;;   ;;;;   ;;;;;  ;;;; ;;  ;;         ;;;;;   ;;;;    ;;; 
+    ;                                                                 
+    ;                                                                 
+    ;                                                                 
+    ;                                                                 
+  
+    (let ()
+      (define-language L
+        (n number)
+        (x variable))
+      
+      (test (redex-let L ([(n_1 n_2) '(1 2)])
+                       (term (n_2 n_1)))
+            (term (2 1)))
+      (test (redex-let L ([(x_i ([x_0 n_0] ... [x_i n_i] [x_i+1 n_i+1] ...))
+                           '(b ([a 1] [b 2] [c 3]))])
+                       (term n_i))
+            2)
+      (test (with-handlers ([exn:fail:redex? exn-message])
+              (redex-let L ([(n) 1]) 'no-exn))
+            "redex-let: term 1 does not match pattern (n)")
+      (test (with-handlers ([exn:fail:redex? exn-message])
+              (redex-let L ([(n_1 ... n_i n_i+1 ...) '(1 2 3)]) 'no-exn))
+            "redex-let: pattern (n_1 ... n_i n_i+1 ...) matched term (1 2 3) multiple ways")
+      (test (redex-let L ([n_1 1])
+                       (redex-let L ([n_1 2] [n_2 (term n_1)])
+                                  (term (n_1 n_2))))
+            (term (2 1)))
+      (test (redex-let L ([n_1 1])
+                       (redex-let* L ([n_1 2] [n_2 (term n_1)])
+                                   (term (n_1 n_2))))
+            (term (2 2)))
+      
+      (test (redex-let L ([(n_1 n_1) '(1 1)]) (term n_1))
+            1)
+      (test-syn-err
+       (redex-let grammar ([(number) 1] [number 1]) (term number))
+       #rx"redex-let: duplicate pattern variable" 1)
+      (test
+       (redex-let* L ([(n_1) '(1)] [n_1 1]) (term n_1))
+       1))
+  
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;
   ;; examples from doc.txt