From 1c8c6ddbeeb42c041f993ca52c11d5d8aebd4136 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Fri, 22 Apr 2011 04:04:56 -0500 Subject: [PATCH] Adds generate-term option for LHS-based generation --- collects/redex/private/keyword-macros.rkt | 31 ++++++----- collects/redex/private/rg.rkt | 66 ++++++++++++++++------- collects/redex/redex.scrbl | 52 +++++++++++++++--- collects/redex/tests/rg-test.rkt | 47 +++++++++++++++- 4 files changed, 156 insertions(+), 40 deletions(-) diff --git a/collects/redex/private/keyword-macros.rkt b/collects/redex/private/keyword-macros.rkt index ba47c3b1ac..7eaae5845c 100644 --- a/collects/redex/private/keyword-macros.rkt +++ b/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)]) - (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)])) - '#,form #,desc - #(#,(syntax-source expr) - #,(syntax-line expr) - #,(syntax-column expr) - #,(syntax-position expr) - #,(syntax-span expr)))) + #,(client-name expr form) '#,form + #,desc #,(src-loc-stx expr))) -(provide parse-kw-args apply-contract) +(provide (all-defined-out)) \ No newline at end of file diff --git a/collects/redex/private/rg.rkt b/collects/redex/private/rg.rkt index 93a26aa328..d9a736a2dc 100644 --- a/collects/redex/private/rg.rkt +++ b/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 (term-fn? tf) (term-fn-get-id tf)))) + (and (identifier? name) + (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 () - [(_ lang pat size . kw-args) - (with-syntax ([generator (syntax/loc stx (generate-term lang pat))]) - (syntax/loc stx - (generator size . kw-args)))] - [(name lang pat) - #`(let ([generate #,(term-generator #'lang #'pat (syntax-e #'name))]) - (with-contract - name #:result - (->* (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 _) (generate size attempt-num retries)]) - term))))])) + (define form-name + (syntax-case stx () + [(name . _) (syntax-e #'name)])) + (define-values (raw-generators args) + (syntax-case stx () + [(_ #:source src . rest) + (values + (cond [(metafunc #'src) + => (λ (f) + #`(let* ([f #,f] + [L (metafunc-proc-lang f)] + [compile-pat (compile L '#,form-name)]) + (map (λ (c) (compile-pat ((metafunc-case-lhs+ c) L))) + (metafunc-proc-cases f))))] + [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 diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 1696e861a7..34569a7965 100644 --- a/collects/redex/redex.scrbl +++ b/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 ...) - (generate-term language @#,ttpattern)] - ([kw-args (code:line #:attempt-num attempts-expr) +@defform*/subs[[(generate-term term-spec size-expr kw-args ...) + (generate-term term-spec)] + ([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 -the given pattern (according to the given language). In its second, -@racket[generate-term] produces a procedure for constructing the same. +In its first form, @racket[generate-term] produces a random term according +to @racket[term-spec], which is either a language and a pattern, the name +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] diff --git a/collects/redex/tests/rg-test.rkt b/collects/redex/tests/rg-test.rkt index c944975f89..99d33adbd5 100644 --- a/collects/redex/tests/rg-test.rkt +++ b/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 ()