added define-union-language

collects/redex/private/matcher.rkt

@@ -257,6 +257,38 @@ See match-a-pattern.rkt for more details
              (unless (memq pat nts)
                (hash-set! ht pat #t)))))])))
 
+;; prefix-nts : string pat -> pat
+(define (prefix-nts prefix pat)
+  (let loop ([pat pat])
+    (match-a-pattern pat
+      [`any pat]
+      [`number pat]
+      [`string pat]
+      [`natural pat]
+      [`integer pat]
+      [`real pat]
+      [`variable pat]
+      [`(variable-except ,s ...) pat]
+      [`(variable-prefix ,s) pat]
+      [`variable-not-otherwise-mentioned pat]
+      [`hole pat]
+      [`(nt ,id) `(nt ,(string->symbol (string-append prefix (symbol->string id))))]
+      [`(name ,name ,pat) `(name , name ,(loop pat))]
+      [`(mismatch-name ,name ,pat) `(mismatch-name ,name ,(loop pat))]
+      [`(in-hole ,p1 ,p2) `(in-hole ,(loop p1) ,(loop p2))]
+      [`(hide-hole ,p) `(hide-hole ,(loop p))]
+      [`(side-condition ,p ,g ,e) `(side-condition ,(loop p) ,g ,e)]
+      [`(cross ,s) pat]
+      [`(list ,sub-pats ...)
+       `(list ,@(for/list ([sub-pat (in-list sub-pats)])
+                  (match sub-pat
+                    [`(repeat ,pat ,name ,mismatch)
+                     `(repeat ,(loop pat) ,name ,mismatch)]
+                    [else
+                     (loop sub-pat)])))]
+      [(? (compose not pair?)) 
+       pat])))
+
 ; build-has-hole-or-hide-hole-ht : (listof nt) -> hash[symbol -o> boolean]
 ; produces a map of nonterminal -> whether that nonterminal could produce a hole
 (define (build-has-hole-or-hide-hole-ht lang)
@@ -1967,4 +1999,5 @@ See match-a-pattern.rkt for more details
          rewrite-ellipses
          build-compatible-context-language
          caching-enabled?
-         check-redudancy)
+         check-redudancy
+         prefix-nts)

collects/redex/private/pict.rkt

@@ -483,6 +483,8 @@
   (do-language->pict 'language->pict lang nts))
 
 (define (do-language->pict what lang specd-non-terminals)
+  (unless (compiled-lang-pict-builder lang)
+    (error what "cannot render the result of define-union-language"))
   (let ([all-non-terminals (hash-map (compiled-lang-ht lang) (λ (x y) x))])
     (when specd-non-terminals
       (check-non-terminals what specd-non-terminals lang))

collects/redex/private/reduction-semantics.rkt

@@ -2616,8 +2616,88 @@
                       (hash-map new-ht (λ (x y) y))
                       (compiled-lang-nt-map old-lang))))
 
-(define (union-language lang1 lang2)
+(define-syntax (define-union-language stx)
-  (void))
+  (syntax-case stx ()
+    [(_ name orig-langs ...)
+     (begin
+       (unless (identifier? (syntax name))
+         (raise-syntax-error 'define-extended-language "expected an identifier" stx #'name))
+       (when (null? (syntax->list #'(orig-langs ...)))
+         (raise-syntax-error 'define-union-language "expected at least one additional language" stx))
+       ;; normalized-orig-langs : (listof (list string[prefix] id (listof symbol)[nts] stx[orig clause in union]))
+       (define normalized-orig-langs
+         (for/list ([orig-lang (in-list (syntax->list #'(orig-langs ...)))])
+           (syntax-case orig-lang ()
+             [x (identifier? #'x) (list "" #'x (language-id-nts #'x 'define-union-language) orig-lang)]
+             [(prefix lang)
+              (and (identifier? #'prefix)
+                   (identifier? #'lang))
+              (list (symbol->string (syntax-e #'prefix)) #'lang (language-id-nts #'lang 'define-union-language) orig-lang)]
+             [else (raise-syntax-error 'define-union-language 
+                                       "malformed additional language"
+                                       stx orig-lang)])))
+       
+       ;; ht : sym -o> stx
+       ;; maps each non-terminal (with its prefix) to the 
+       ;; syntax object that it comes from in the original
+       ;; define-union-language declaration
+       (define names-table (make-hash))
+       
+       (for ([normalized-orig-lang (in-list normalized-orig-langs)])
+         (define prefix (list-ref normalized-orig-lang 0))
+         (for ([no-prefix-nt (in-list (list-ref normalized-orig-lang 2))])
+           (define nt (string->symbol (string-append prefix (symbol->string no-prefix-nt))))
+           (let ([prev (hash-ref names-table nt #f)])
+             (when prev
+               (raise-syntax-error 'define-union-language 
+                                   (format "two sublanguages both contribute the non-terminal: ~a" nt)
+                                   #f
+                                   #f
+                                   (list prev
+                                         (list-ref normalized-orig-lang 3))))
+             (hash-set! names-table nt (list-ref normalized-orig-lang 3)))))
+       
+       (with-syntax ([(all-names ...) (sort (hash-map names-table (λ (x y) x)) string<=? #:key symbol->string)]
+                     [((prefix old-lang _1 _2) ...) normalized-orig-langs]
+                     [(define-language-name) (generate-temporaries #'(name))])
+         #'(begin
+             (define define-language-name (union-language (list (list 'prefix old-lang) ...)))
+             (define-syntax name
+               (make-set!-transformer
+                (make-language-id
+                 (λ (stx)
+                   (syntax-case stx (set!)
+                     [(set! x e) (raise-syntax-error 'define-extended-language "cannot set! identifier" stx #'e)]
+                     [(x e (... ...)) #'(define-language-name e (... ...))]
+                     [x 
+                      (identifier? #'x)
+                      #'define-language-name]))
+                 '(all-names ...)))))))]))
+
+(define (union-language old-langs/prefixes)
+  (define new-nt-map
+    (for/list ([old-pr (in-list old-langs/prefixes)])
+      (define prefix (list-ref old-pr 0))
+      (define nt-map (compiled-lang-nt-map (list-ref old-pr 1)))
+      (for/list ([lst (in-list nt-map)])
+        (for/list ([sym (in-list lst)])
+          (string->symbol (string-append prefix (symbol->string sym)))))))
+  
+  (define new-nts
+    (apply
+     append
+     (for/list ([old-lang/prefix (in-list old-langs/prefixes)])
+       (define prefix (list-ref old-lang/prefix 0))
+       (define lang (compiled-lang-lang (list-ref old-lang/prefix 1)))
+       (for/list ([nt (in-list lang)])
+         (make-nt (string->symbol (string-append prefix (symbol->string (nt-name nt))))
+                  (for/list ([rhs (in-list (nt-rhs nt))])
+                    (make-rhs (prefix-nts prefix (rhs-pattern rhs)))))))))
+  
+  (compile-language #f
+                    new-nts
+                    new-nt-map))
+
 
 ;; find-primary-nt : symbol lang -> symbol or #f
 ;; returns the primary non-terminal for a given nt, or #f if `nt' isn't bound in the language.
@@ -2937,6 +3017,7 @@
          
          define-language
          define-extended-language
+         define-union-language
          
          define-metafunction
          define-metafunction/extension

collects/redex/private/ref.scrbl

@@ -615,7 +615,7 @@ A @racket[non-terminal-def] comprises one or more non-terminal names
 (considered aliases) followed by one or more productions.
 
 For example, the following defines @deftech{@racket[lc-lang]} as the
-grammar of the lambda calculus:
+grammar of the λ-calculus:
 
 @racketblock[
   (define-language lc-lang
@@ -624,7 +624,7 @@ grammar of the lambda calculus:
        v)
     (c (v ... c e ...)
        hole)
-    (v (lambda (x ...) e))
+    (v (λ (x ...) e))
     (x variable-not-otherwise-mentioned))
 ]
 
@@ -652,7 +652,7 @@ extended non-terminals. For example, this language:
     (v ....     (code:comment "extend the previous `v' non-terminal")
        +
        number)
-    (x (variable-except lambda +)))
+    (x (variable-except λ +)))
 ]
 
 extends lc-lang with two new alternatives for the @racket[v]
@@ -676,6 +676,37 @@ defined together, extending any one of those non-terminals
 extends all of them.
 }
 
+@defform/subs[(define-union-language L base/prefix-lang ...)
+              ([base/prefix-lang lang-id
+                                 (prefix lang-id)])]{
+  Constructs a language that is the union of all of the
+  languages listed in the @racket[base/prefix-lang].
+  
+  If a language has a prefix, then all of the non-terminals
+  from that language have the corresponding prefix in 
+  the union language. The prefix helps avoid collisions
+  between the constituent language's non-terminals
+  (which is illegal).
+  
+  For example, with two these two languages:
+  @racketblock[(define-language UT
+                 (e (e e)
+                    (λ (x) e)
+                    x))
+               
+               (define-language WT
+                 (e (e e)
+                    (λ (x t) e)
+                    x)
+                 (t (→ t t)
+                    num))]
+  then this declaration:
+  @racketblock[(define-union-language B (ut. UT) (wt. WT))]
+  will create a language named @racket[B] containing the non-terminals
+  @racket[ut.e], @racket[wt.e], and @racket[wt.t] consisting
+  of the productions listed in the original languages.
+}
+                                                                                
 @defproc[(language-nts [lang compiled-lang?]) (listof symbol?)]{
 
 Returns the list of non-terminals (as symbols) that are
@@ -737,7 +768,7 @@ For example, the expression
 @racketblock[
   (reduction-relation
    lc-lang
-   (--> (in-hole c_1 ((lambda (variable_i ...) e_body) v_i ...))
+   (--> (in-hole c_1 ((λ (variable_i ...) e_body) v_i ...))
         (in-hole c_1 ,(foldl lc-subst 
                              (term e_body) 
                              (term (v_i ...)) 
@@ -816,7 +847,7 @@ For example, this expression
 @racketblock[
   (reduction-relation
    lc-num-lang
-   (==> ((lambda (variable_i ...) e_body) v_i ...)
+   (==> ((λ (variable_i ...) e_body) v_i ...)
         ,(foldl lc-subst 
                 (term e_body) 
                 (term (v_i ...)) 
@@ -829,7 +860,7 @@ For example, this expression
     (==> a b)])
 ]
   
-defines reductions for the lambda calculus with numbers,
+defines reductions for the λ-calculus with numbers,
 where the @tt{==>} shortcut is defined by reducing in the context
 @tt{c}.
 
@@ -1016,7 +1047,7 @@ an expression in the lc-lang above:
       [(free-vars (e_1 e_2 ...))
        (∪ (free-vars e_1) (free-vars e_2) ...)]
       [(free-vars x) (x)]
-      [(free-vars (lambda (x ...) e))
+      [(free-vars (λ (x ...) e))
        (- (free-vars e) (x ...))])
 ]
 
@@ -1025,7 +1056,7 @@ The first argument to define-metafunction is the grammar
 each variation of expressions (e in lc-lang). The free variables of an
 application are the free variables of each of the subterms;
 the free variables of a variable is just the variable
-itself, and the free variables of a lambda expression are
+itself, and the free variables of a λ expression are
 the free variables of the body, minus the bound parameters.
 
 Here are the helper metafunctions used above.
@@ -1807,7 +1838,7 @@ exploring reduction sequences.
                  [#:pred pred
                          (or/c (-> sexp any)
                                (-> sexp term-node? any))
-                         (lambda (x) #t)]
+                         (λ (x) #t)]
                  [#:pp pp
                        (or/c (any -> string)
                              (any output-port number (is-a?/c text%) -> void))
@@ -1816,11 +1847,11 @@ exploring reduction sequences.
                   (listof 
                    (cons/c string? 
                            (and/c (listof (or/c string? (is-a?/c color%)))
-                                  (lambda (x) (<= 0 (length x) 6)))))
+                                  (λ (x) (<= 0 (length x) 6)))))
                   '()]
                  [#:racket-colors? racket-colors? boolean? #t]
                  [#:scheme-colors? scheme-colors? boolean? racket-colors?]
-                 [#:filter term-filter (-> any/c (or/c #f string?) any/c) (lambda (x y) #t)]
+                 [#:filter term-filter (-> any/c (or/c #f string?) any/c) (λ (x y) #t)]
                  [#:x-spacing x-spacing number? 15]
                  [#:y-spacing y-spacing number? 15]
                  [#:layout layout (-> (listof term-node?) void) void]
@@ -1926,7 +1957,7 @@ inserted into the editor by this library have a
                     [#:pred pred
                             (or/c (-> sexp any)
                                   (-> sexp term-node? any))
-                            (lambda (x) #t)]
+                            (λ (x) #t)]
                     [#:pp pp
                           (or/c (any -> string)
                                 (any output-port number (is-a?/c text%) -> void))
@@ -1935,9 +1966,9 @@ inserted into the editor by this library have a
                               (listof 
                                (cons/c string?
                                        (and/c (listof (or/c string? (is-a?/c color%)))
-                                              (lambda (x) (<= 0 (length x) 6)))))
+                                              (λ (x) (<= 0 (length x) 6)))))
                               '()]
-                    [#:filter term-filter (-> any/c (or/c #f string?) any/c) (lambda (x y) #t)]
+                    [#:filter term-filter (-> any/c (or/c #f string?) any/c) (λ (x y) #t)]
                     [#:layout layout (-> (listof term-node?) void) void]
                     [#:x-spacing x-spacing number? 15]
                     [#:y-spacing y-spacing number? 15]

collects/redex/reduction-semantics.rkt

@@ -22,6 +22,7 @@
          
          define-language
          define-extended-language
+         define-union-language
          plug
          compiled-lang?
          term

collects/redex/tests/run-err-tests/define-union-language.rktd

@@ -0,0 +1,6 @@
+("render-language: cannot render the result of define-union-language"
+ ([rl (render-language L2)]) ([L2 L2] [L L])
+ (let ()
+   (define-language L (e any))
+   (define-union-language L2 L)
+   rl))

collects/redex/tests/syn-err-tests/language-definition.rktd

@@ -27,3 +27,21 @@
 (#rx"expected production" ([not-prod ::=]) (define-language L (x ::= y not-prod z)))
 (#rx"expected non-terminal definition" ([not-def q]) (define-language L not-def))
 (#rx"expected non-terminal definition" ([not-def ()]) (define-language L not-def))
+
+("define-union-language: two sublanguages both contribute the non-terminal: e"
+ ([L1r L1] [L2r L2]) ([L1 L1] [L2 L2])
+ (let ()
+   (define-language L1
+     (e any))
+   (define-language L2
+     (e any))
+   (define-union-language L L1r L2r)))
+
+("define-union-language: two sublanguages both contribute the non-terminal: -e"
+ ([L1r L1] [L2r (- L2)]) ([L1 L1] [L2 L2])
+ (let ()
+   (define-language L1
+     (-e any))
+   (define-language L2
+     (e any))
+   (define-union-language L L1r L2r)))

collects/redex/tests/tl-test.rkt

@@ -405,6 +405,31 @@
         (::= () (number ::=)))
       (test (and (redex-match L ::= '(1 ())) #t) #t)))
   
+  (let ()
+    (define-language L1
+      ((q x) 1 2 3)
+      ((y w) 4 5 6 x)
+      (z 7 8 9))
+    
+    (define-language L2
+      ((x y) 100 101 102)
+      (b 103 x))
+    
+    (define-union-language L L1 (- L2))
+    
+    (test (and (redex-match L x 3) #t) #t)
+    (test (and (redex-match L y 2) #t) #t)
+    (test (redex-match L x 100) #f)
+    (test (and (redex-match L -x 100) #t) #t)
+    (test (and (redex-match L -b 100) #t) #t)
+    (test (redex-match L -b 3) #f))
+
+  (parameterize ([current-namespace (make-base-namespace)])
+    (eval '(require redex/reduction-semantics redex/pict))
+    (eval '(define-language L
+             (s a b c)))
+    (exec-runtime-error-tests "run-err-tests/define-union-language.rktd"))
+  
   (exec-syntax-error-tests "syn-err-tests/language-definition.rktd")
 ;                                                                                             
 ;                                                                                             

doc/release-notes/redex/HISTORY.txt

@@ -2,6 +2,8 @@ v5.2.2
 
   * added the amb tutorial.
 
+  * added define-union-language
+
 v5.2.1
 
   * rewrote the internals of the pattern matcher to be more consistent