Adds generate-term option for LHS-based generation

collects/redex/private/keyword-macros.rkt

@@ -34,19 +34,24 @@
              (syntax rest))]
       [else (raise-syntax-error #f "bad keyword argument syntax" source rest)])))
 
+(define (client-name stx form)
+  (let ([m (syntax-source-module stx)])
+    (cond [(module-path-index? m)
+           (format "~a" (module-path-index-resolve m))]
+          [(or (symbol? m) (path? m))
+           (format "~a" m)]
+          [else (format "~s client" form)])))
+
+(define (src-loc-stx stx)
+  #`#(#,(syntax-source stx)
+      #,(syntax-line stx) 
+      #,(syntax-column stx) 
+      #,(syntax-position stx)
+      #,(syntax-span stx)))
+
 (define (apply-contract ctc expr desc form)
   #`(contract #,ctc #,expr
-              #,(let ([m (syntax-source-module expr)])
+              #,(client-name expr form) '#,form
-                  (cond [(module-path-index? m)
+              #,desc #,(src-loc-stx expr)))
-                         (format "~a" (module-path-index-resolve m))]
-                        [(or (symbol? m) (path? m))
-                         (format "~a" m)]
-                        [else (format "~s client" form)]))
-              '#,form #,desc
-              #(#,(syntax-source expr)
-                #,(syntax-line expr) 
-                #,(syntax-column expr) 
-                #,(syntax-position expr)
-                #,(syntax-span expr))))
 
-(provide parse-kw-args apply-contract)
+(provide (all-defined-out))

collects/redex/private/rg.rkt

@@ -692,8 +692,9 @@
 (define-language sexp (sexp variable string number hole (sexp ...)))
 
 (define-for-syntax (metafunc name)
-  (let ([tf (syntax-local-value name (λ () #f))])
+  (and (identifier? name)
-    (and (term-fn? tf) (term-fn-get-id tf))))
+       (let ([tf (syntax-local-value name (λ () #f))])
+         (and (term-fn? tf) (term-fn-get-id tf)))))
 
 (define-for-syntax (metafunc/err name stx)
   (let ([m (metafunc name)])
@@ -707,21 +708,50 @@
     #`((compile #,lang '#,what) `pattern)))
 
 (define-syntax (generate-term stx)
-  (syntax-case stx ()
+  (define form-name
-    [(_ lang pat size . kw-args)
+    (syntax-case stx ()
-     (with-syntax ([generator (syntax/loc stx (generate-term lang pat))])
+      [(name . _) (syntax-e #'name)]))
-       (syntax/loc stx
+  (define-values (raw-generators args)
-         (generator size . kw-args)))]
+    (syntax-case stx ()
-    [(name lang pat)
+      [(_ #:source src . rest)
-     #`(let ([generate #,(term-generator #'lang #'pat (syntax-e #'name))])
+       (values 
-         (with-contract
+        (cond [(metafunc #'src) 
-          name #:result 
+               => (λ (f)
-          (->* (natural-number/c)
+                    #`(let* ([f #,f]
-               (#:attempt-num natural-number/c #:retries natural-number/c)
+                             [L (metafunc-proc-lang f)]
-               any)
+                             [compile-pat (compile L '#,form-name)])
-          (λ (size #:attempt-num [attempt-num 1] #:retries [retries default-retries])
+                            (map (λ (c) (compile-pat ((metafunc-case-lhs+ c) L))) 
-            (let-values ([(term _) (generate size attempt-num retries)])
+                                 (metafunc-proc-cases f))))]
-              term))))]))
+              [else
+               #`(let* ([r #,(apply-contract #'reduction-relation?  #'src "#:source argument" form-name)]
+                        [L (reduction-relation-lang r)]
+                        [compile-pat (compile L '#,form-name)])
+                       (map (λ (p) (compile-pat ((rewrite-proc-lhs p) L)))
+                            (reduction-relation-make-procs r)))])
+        #'rest)]
+      [(_ lang pat . rest)
+       (values #`(list #,(term-generator #'lang #'pat form-name))
+               #'rest)]))
+  (define generator-syntax
+    #`(make-generator #,raw-generators '#,form-name #,(client-name stx form-name) #,(src-loc-stx stx)))
+  (syntax-case args ()
+    [()
+     generator-syntax]
+    [(size . kw-args)
+     (quasisyntax/loc stx
+       (#,generator-syntax size . kw-args))]))
+
+(define (make-generator raw-generators form-name client-name src-loc)
+  (contract (->* (natural-number/c)
+                 (#:attempt-num natural-number/c #:retries natural-number/c)
+                 any)
+            (λ (size #:attempt-num [attempt-num 1] #:retries [retries default-retries])
+              (let-values ([(term _) ((match raw-generators
+                                        [(list g) g]
+                                        [_ (pick-from-list raw-generators)])
+                                      size attempt-num retries)])
+                term))
+            form-name client-name #f src-loc))
 
 (define-for-syntax (show-message stx)
   (syntax-case stx ()
@@ -793,7 +823,7 @@
                (parameterize ([attempt->size #,size-stx])
                #,(if source-stx
                      #`(let-values ([(metafunc/red-rel num-cases) 
-                                     #,(cond [(and (identifier? source-stx) (metafunc source-stx))
+                                     #,(cond [(metafunc source-stx)
                                               => (λ (x) #`(values #,x (length (metafunc-proc-cases #,x))))]
                                              [else
                                               #`(let ([r #,(apply-contract #'reduction-relation? source-stx 

collects/redex/redex.scrbl

@@ -1257,24 +1257,62 @@ metafunctions or unnamed reduction-relation cases) to application counts.}
            (values (covered-cases equals-coverage)
                    (covered-cases plus-coverage))))]
 
-@defform*/subs[[(generate-term language @#,ttpattern size-expr kw-args ...)
+@defform*/subs[[(generate-term term-spec size-expr kw-args ...)
-                (generate-term language @#,ttpattern)]
+                (generate-term term-spec)]
-              ([kw-args (code:line #:attempt-num attempts-expr)
+              ([term-spec (code:line language @#,ttpattern)
+                          (code:line #:source metafunction)
+                          (code:line #:source relation-expr)]
+               [kw-args (code:line #:attempt-num attempts-expr)
                         (code:line #:retries retries-expr)])
               #:contracts ([size-expr natural-number/c]
                            [attempt-num-expr natural-number/c]
                            [retries-expr natural-number/c])]{
                                                              
-In its first form, @racket[generate-term] produces a random term matching
+In its first form, @racket[generate-term] produces a random term according
-the given pattern (according to the given language). In its second, 
+to @racket[term-spec], which is either a language and a pattern, the name
-@racket[generate-term] produces a procedure for constructing the same.
+of a metafunction, or an expression producing a reduction relation. In the
+first of these cases, the produced term matches the given pattern (interpreted 
+according to the definition of the given language). In the second and third cases, 
+the produced term matches one of the clauses of the specified metafunction or
+reduction relation.
+
+In its second form, @racket[generate-term] produces a procedure for constructing 
+terms according to @racket[term-spec].
 This procedure expects @racket[size-expr] (below) as its sole positional
 argument and allows the same optional keyword arguments as the first form.
 The second form may be more efficient when generating many terms.
 
 The argument @racket[size-expr] bounds the height of the generated term
 (measured as the height of its parse tree). 
-         
+
+@examples[
+#:eval redex-eval
+       (define-language L
+         (n number))
+       
+       (generate-term L (+ n_1 n_2) 5)
+       
+       (define R
+         (reduction-relation 
+          L
+          (--> (one-clause n) ())
+          (--> (another-clause n) ())))
+       
+       (random-seed 0)
+       
+       (generate-term #:source R 5)
+       
+       (define R-left-hand-sides
+         (generate-term #:source R))
+       (R-left-hand-sides 0)
+       (R-left-hand-sides 1)
+       
+       (define-metafunction L
+         [(F one-clause n) ()]
+         [(F another-clause n) ()])
+                                   
+       (generate-term #:source F 5)]
+
 The optional keyword argument @racket[attempt-num-expr] 
 (default @racket[1]) provides coarse grained control over the random
 decisions made during generation; increasing @racket[attempt-num-expr]

collects/redex/tests/rg-test.rkt

@@ -38,7 +38,7 @@
        (test-contract-violation 
         (output (λ () expr))
         #:blaming "rg-test"
-        #:message ""
+        #:message name
         #:extract (match-lambda
                     [(exn:fail:redex:test _ _ (? exn:fail:contract:blame? e) _) e]
                     [x x])))]))
@@ -220,14 +220,57 @@
 (let ()
   (define-language L
     (n 1))
+  
   (test ((generate-term L n) 0) 1)
   (test ((generate-term L n) 0 #:retries 0) 1)
   (test ((generate-term L n) 0 #:attempt-num 0) 1)
+
   (test (with-handlers ([exn:fail:syntax? exn-message])
           (parameterize ([current-namespace ns])
             (expand #'(generate-term M n))))
         #rx"generate-term: expected a identifier defined by define-language( in: M)?$")
-  (test-contract-violation/client (generate-term L n 1.5)))
+  (test-contract-violation/client (generate-term L n 1.5))
+  (test-contract-violation/client (generate-term L n 1 #:retries .5))
+  (test-contract-violation/client (generate-term L n 1 #:attempt-num .5))
+  (test-contract-violation/client "#:source" (generate-term #:source 'not-a-reduction-relation)))
+
+(let ([set-rand-2 
+       (λ (to-be prg)
+         (parameterize ([current-pseudo-random-generator prg])
+           (random-seed 
+            (case to-be
+              [(0) 5]
+              [(1) 0]))))])
+  
+  (set-rand-2 0 (current-pseudo-random-generator))
+  (test (random 2) 0)
+  (set-rand-2 1 (current-pseudo-random-generator))
+  (test (random 2) 1)
+  
+  (define-language L)
+  (define R
+    (reduction-relation 
+     L
+     (--> a 1)
+     (--> b 2)))
+  (define-metafunction L
+    [(F a) 1]
+    [(F b) 2])
+  
+  (set-rand-2 0 (redex-pseudo-random-generator))
+  (test (generate-term #:source R 0) 'a)
+  (set-rand-2 1 (redex-pseudo-random-generator))
+  (test ((generate-term #:source R) 0) 'b)
+  
+  (set-rand-2 0 (redex-pseudo-random-generator))
+  (test ((generate-term #:source F) 0) '(a))
+  (set-rand-2 1 (redex-pseudo-random-generator))
+  (test (generate-term #:source F 0) '(b))
+  
+  (let ([before (pseudo-random-generator->vector (redex-pseudo-random-generator))])
+    (generate-term L () 0)
+    (test (pseudo-random-generator->vector (redex-pseudo-random-generator))
+          before)))
 
 ;; variable-except pattern
 (let ()