suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adds generate-term option for LHS-based generation

Browse Source
This commit is contained in:
Casey Klein 2011-04-22 04:04:56 -05:00
parent 362a6d75a5
commit 1c8c6ddbee
4 changed files with 156 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/redex/private/keyword-macros.rkt
View File

@ -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))

66
collects/redex/private/rg.rkt
View File

@ -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

52
collects/redex/redex.scrbl
View File

@ -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]

47
collects/redex/tests/rg-test.rkt
View File

@ -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 ()