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

adjust generate-term so that it has an '=' in its concrete

Browse Source 
syntax when generating something from a metafunction

export redex-generator (and add docs)

rename generate-types.rkt to typing-rules-no-ellipses.rkt
This commit is contained in:
Robby Findler 2012-11-01 14:38:36 -05:00
parent 478fedeeb7
commit 3d5178bcb0
7 changed files with 86 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/redex/examples/define-judgment-form/generate-types.rkt → collects/redex/examples/define-judgment-form/typing-rules-no-ellipses.rkt
View File

@ -8,9 +8,8 @@
;; This file makes some small changes to the system in ;; This file makes some small changes to the system in
;; typing-rules.rkt (in the same directory) to allow generation ;; typing-rules.rkt (in the same directory) to allow generation
;; of terms that satisfy the "typeof" judgment-form. Specifically, ;; of terms that satisfy the "typeof" judgment-form. Specifically,
;; since this kind of random generation doesn't yet support ellipses, ;; since generation doesn't yet support ellipses, they have to be
;; they have to be eliminated form the judgment-form and the ;; eliminated from the judgment-form and the metafunctions it depends on.
;; metafunctions it depends on.
(define-language STLC (define-language STLC
(e (λ (x τ) e) (e (λ (x τ) e)
@ -77,12 +76,20 @@
(typeof () e τ) (typeof () e τ)
5)) 5))
(define (random-terms n) (define (random-typed-terms n)
(define gen-one (redex-generator STLC (typeof () e τ) 5))
(for/list ([_ n]) (for/list ([_ n])
(match (random-typed-term) (extract-term-from-derivation
[`(typeof () ,e ,t) (gen-one))))
(define types (judgment-holds (typeof () ,e τ) τ))
(unless (= 1 (length types)) (define (extract-term-from-derivation t)
(error 'typeof "non-unique types: ~s in ~s\n" types e)) (match t
(test-equal (car types) t) [`(typeof () ,e ,t)
e]))) ;; test to make sure the generator
;; generated something that the
;; judgment form actually accepts
(define types (judgment-holds (typeof () ,e τ) τ))
(unless (= 1 (length types))
(error 'typeof "non-unique types: ~s in ~s\n" types e))
(test-equal (car types) t)
e]))

15
collects/redex/private/generate-term.rkt
View File

@ -341,12 +341,19 @@
(let ([body-code (let ([body-code
(λ (res size) (λ (res size)
#`(generate-mf-pat language (jf/mf-id . args) #,res #,size))]) #`(generate-mf-pat language (jf/mf-id . args) #,res #,size))])
(syntax-case #'rest () (syntax-case #'rest (=)
[(res) [(= res)
#`(λ (size) #`(λ (size)
#,(body-code #'size))] #,(body-code #'res #'size))]
[(res size) [(= res size)
(body-code #'res #'size)] (body-code #'res #'size)]
[(x . y)
(or (not (identifier? #'x))
(not (free-identifier=? #'= #'x)))
(raise-syntax-error 'generate-term
"expected to find ="
stx
#'x)]
[whatever [whatever
(signal-error #'whatever)]))))] (signal-error #'whatever)]))))]
[(judgment-form-id? #'jf/mf-id) [(judgment-form-id? #'jf/mf-id)

2
collects/redex/private/judgment-form.rkt
View File

@ -413,7 +413,7 @@
; Introduce the names before using them, to allow ; Introduce the names before using them, to allow
; judgment form definition at the top-level. ; judgment form definition at the top-level.
#`(begin #`(begin
(define-syntaxes (judgment-form-runtime-proc judgment-form-lws) (values)) (define-syntaxes (judgment-form-runtime-proc judgment-form-lws judgment-runtime-gen-clauses) (values))
#,definitions) #,definitions)
definitions)) definitions))
'disappeared-use 'disappeared-use

1
collects/redex/reduction-semantics.rkt
View File

@ -64,6 +64,7 @@
generate-term generate-term
check-metafunction check-metafunction
check-reduction-relation check-reduction-relation
redex-generator
exn:fail:redex:generation-failure? exn:fail:redex:generation-failure?
(struct-out exn:fail:redex:test) (struct-out exn:fail:redex:test)
(struct-out counterexample)) (struct-out counterexample))

24
collects/redex/scribblings/ref.scrbl
View File

@ -1641,7 +1641,7 @@ metafunctions or unnamed reduction-relation cases) to application counts.}
(generate-term term-spec)] (generate-term term-spec)]
([term-spec (code:line language @#,ttpattern) ([term-spec (code:line language @#,ttpattern)
(code:line language #:satisfying (judgment-form-id @#,ttpattern ...)) (code:line language #:satisfying (judgment-form-id @#,ttpattern ...))
(code:line language #:satisfying (metafunction-id @#,ttpattern ...) @#,ttpattern) (code:line language #:satisfying (metafunction-id @#,ttpattern ...) = @#,ttpattern)
(code:line #:source metafunction) (code:line #:source metafunction)
(code:line #:source relation-expr)] (code:line #:source relation-expr)]
[kw-args (code:line #:attempt-num attempts-expr) [kw-args (code:line #:attempt-num attempts-expr)
@ -1824,6 +1824,27 @@ term that does not match @racket[pattern].}
(add1 (abs n))) (add1 (abs n)))
#:attempts 3)] #:attempts 3)]
@defform/subs[(redex-generator language-id satisfying size-expr)
([satisfying (judgment-form-id @#,ttpattern ...)
(code:line (metafunction-id @#,ttpattern ...) = @#,ttpattern)])
#:contracts ([size-expr natural-number/c])]{
@italic{WARNING: @racket[redex-generator] is a new, experimental form,
and its API may change.}
Returns a thunk that, each time it is called, either generates a random
s-expression based on @racket[satisfying] or fails to (and returns @racket[#f]).
The terms returned by a particular thunk are guaranteed to be distinct.
@examples[#:eval
redex-eval
(define gen-sum (redex-generator nats (sum n_1 n_2 n_3) 5))
(gen-sum)
(gen-sum)
(gen-sum)
(gen-sum)]
}
@defstruct[counterexample ([term any/c]) #:inspector #f]{ @defstruct[counterexample ([term any/c]) #:inspector #f]{
Produced by @racket[redex-check], @racket[check-reduction-relation], and Produced by @racket[redex-check], @racket[check-reduction-relation], and
@racket[check-metafunction] when testing falsifies a property.} @racket[check-metafunction] when testing falsifies a property.}
@ -1834,6 +1855,7 @@ Raised by @racket[redex-check], @racket[check-reduction-relation], and
The @racket[exn:fail:redex:test-source] component contains the exception raised by the property, The @racket[exn:fail:redex:test-source] component contains the exception raised by the property,
and the @racket[exn:fail:redex:test-term] component contains the term that induced the exception.} and the @racket[exn:fail:redex:test-term] component contains the term that induced the exception.}
@defform/subs[(check-reduction-relation relation property kw-args ...) @defform/subs[(check-reduction-relation relation property kw-args ...)
([kw-arg (code:line #:attempts attempts-expr) ([kw-arg (code:line #:attempts attempts-expr)
(code:line #:retries retries-expr) (code:line #:retries retries-expr)

63
collects/redex/tests/gen-test.rkt
View File

@ -133,8 +133,7 @@
(test-equal (generate-term STLC (test-equal (generate-term STLC
#:satisfying #:satisfying
(lookup x ([x int] ([x (int → int)] •))) (lookup x ([x int] ([x (int → int)] •))) = (int → int)
(int → int)
6) 6)
#f)) #f))
@ -317,7 +316,7 @@
(void)])) (void)]))
(for ([_ 50]) (for ([_ 50])
(define t (generate-term l #:satisfying (fltr n e) e_1 5)) (define t (generate-term l #:satisfying (fltr n e) = e_1 5))
(match t (match t
[`((fltr ,n ,e) = ,e1) [`((fltr ,n ,e) = ,e1)
(test-equal (term (fltr ,n ,e)) e1)] (test-equal (term (fltr ,n ,e)) e1)]
@ -332,9 +331,7 @@
[`((fltr ,n ,e) = ,e1) [`((fltr ,n ,e) = ,e1)
(test-equal (term (fltr ,n ,e)) e1)]) (test-equal (term (fltr ,n ,e)) e1)])
terms) terms)
(void) (void))
)
(let () (let ()
@ -360,30 +357,30 @@
[(is-a/b/c/d/e? e) T]) [(is-a/b/c/d/e? e) T])
(test-equal (generate-term L #:satisfying (is-a? a) any +inf.0) (test-equal (generate-term L #:satisfying (is-a? a) = any +inf.0)
'((is-a? a) = T)) '((is-a? a) = T))
(test-equal (generate-term L #:satisfying (is-a? b) any +inf.0) (test-equal (generate-term L #:satisfying (is-a? b) = any +inf.0)
'((is-a? b) = F)) '((is-a? b) = F))
(test-equal (generate-term L #:satisfying (is-a? c) any +inf.0) (test-equal (generate-term L #:satisfying (is-a? c) = any +inf.0)
'((is-a? c) = F)) '((is-a? c) = F))
(test-equal (generate-term L #:satisfying (is-a/b? a) any +inf.0) (test-equal (generate-term L #:satisfying (is-a/b? a) = any +inf.0)
'((is-a/b? a) = T)) '((is-a/b? a) = T))
(test-equal (generate-term L #:satisfying (is-a/b? b) any +inf.0) (test-equal (generate-term L #:satisfying (is-a/b? b) = any +inf.0)
'((is-a/b? b) = T)) '((is-a/b? b) = T))
(test-equal (generate-term L #:satisfying (is-a/b? c) any +inf.0) (test-equal (generate-term L #:satisfying (is-a/b? c) = any +inf.0)
'((is-a/b? c) = F)) '((is-a/b? c) = F))
(test-equal (generate-term L #:satisfying (is-a/b/c/d/e? a) any +inf.0) (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? a) = any +inf.0)
'((is-a/b/c/d/e? a) = T)) '((is-a/b/c/d/e? a) = T))
(test-equal (generate-term L #:satisfying (is-a/b/c/d/e? b) any +inf.0) (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? b) = any +inf.0)
'((is-a/b/c/d/e? b) = T)) '((is-a/b/c/d/e? b) = T))
(test-equal (generate-term L #:satisfying (is-a/b/c/d/e? c) any +inf.0) (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? c) = any +inf.0)
'((is-a/b/c/d/e? c) = T)) '((is-a/b/c/d/e? c) = T))
(test-equal (generate-term L #:satisfying (is-a/b/c/d/e? d) any +inf.0) (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? d) = any +inf.0)
'((is-a/b/c/d/e? d) = T)) '((is-a/b/c/d/e? d) = T))
(test-equal (generate-term L #:satisfying (is-a/b/c/d/e? e) any +inf.0) (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? e) = any +inf.0)
'((is-a/b/c/d/e? e) = T)) '((is-a/b/c/d/e? e) = T))
(test-equal (generate-term L #:satisfying (is-a/b/c/d/e? f) any +inf.0) (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? f) = any +inf.0)
'((is-a/b/c/d/e? f) = F))) '((is-a/b/c/d/e? f) = F)))
;; errors for unsupprted pats ;; errors for unsupprted pats
@ -394,7 +391,7 @@
(define-metafunction L (define-metafunction L
[(f n) (g n)]) [(f n) (g n)])
(test (with-handlers ((exn:fail? exn-message)) (test (with-handlers ((exn:fail? exn-message))
(generate-term L #:satisfying (f any) any +inf.0) (generate-term L #:satisfying (f any) = any +inf.0)
"didn't raise an exception") "didn't raise an exception")
#rx".*generate-term:.*side-condition.*")) #rx".*generate-term:.*side-condition.*"))
(let () (let ()
@ -404,7 +401,7 @@
(define-metafunction L (define-metafunction L
[(f n) (g n)]) [(f n) (g n)])
(test (with-handlers ((exn:fail? exn-message)) (test (with-handlers ((exn:fail? exn-message))
(generate-term L #:satisfying (f any) any +inf.0) (generate-term L #:satisfying (f any) = any +inf.0)
"didn't raise an exception") "didn't raise an exception")
#rx".*generate-term:.*repeat.*")) #rx".*generate-term:.*repeat.*"))
@ -441,7 +438,7 @@
(where q_3 (f q_2))]) (where q_3 (f q_2))])
(test (with-handlers ([exn:fail? exn-message]) (test (with-handlers ([exn:fail? exn-message])
(generate-term L #:satisfying (f r_1) r_2 +inf.0)) (generate-term L #:satisfying (f r_1) = r_2 +inf.0))
#rx".*generate-term:.*undatum.*")) #rx".*generate-term:.*undatum.*"))
@ -451,7 +448,7 @@
[(n any) any]) [(n any) any])
(define-metafunction L (define-metafunction L
[(f n) (n 1)]) [(f n) (n 1)])
(test-equal (generate-term L #:satisfying (f any_1) any_2 +inf.0) (test-equal (generate-term L #:satisfying (f any_1) = any_2 +inf.0)
'((f 2) = (2 1)))) '((f 2) = (2 1))))
(let () (let ()
@ -460,7 +457,7 @@
[(n any) any]) [(n any) any])
(define-metafunction L (define-metafunction L
[(f n) n]) [(f n) n])
(test-equal (generate-term L #:satisfying (f any_1) any_2 +inf.0) (test-equal (generate-term L #:satisfying (f any_1) = any_2 +inf.0)
'((f 2) = 2))) '((f 2) = 2)))
(let () (let ()
@ -477,25 +474,25 @@
[(t n_1 n_2) [(t n_1 n_2)
4]) 4])
(test-equal (generate-term l #:satisfying (t 1 1) 1 +inf.0) (test-equal (generate-term l #:satisfying (t 1 1) = 1 +inf.0)
'((t 1 1) = 1)) '((t 1 1) = 1))
(test-equal (generate-term l #:satisfying (t 1 1) 2 +inf.0) (test-equal (generate-term l #:satisfying (t 1 1) = 2 +inf.0)
#f) #f)
(test-equal (generate-term l #:satisfying (t 1 2) 2 +inf.0) (test-equal (generate-term l #:satisfying (t 1 2) = 2 +inf.0)
'((t 1 2) = 2)) '((t 1 2) = 2))
(test-equal (generate-term l #:satisfying (t 1 2) 3 +inf.0) (test-equal (generate-term l #:satisfying (t 1 2) = 3 +inf.0)
#f) #f)
(test-equal (generate-term l #:satisfying (t 1 3) 3 +inf.0) (test-equal (generate-term l #:satisfying (t 1 3) = 3 +inf.0)
'((t 1 3) = 3)) '((t 1 3) = 3))
(test-equal (generate-term l #:satisfying (t 1 3) 4 +inf.0) (test-equal (generate-term l #:satisfying (t 1 3) = 4 +inf.0)
#f) #f)
(test-equal (generate-term l #:satisfying (t 6 7) 4 +inf.0) (test-equal (generate-term l #:satisfying (t 6 7) = 4 +inf.0)
'((t 6 7) = 4)) '((t 6 7) = 4))
(test-equal (generate-term l #:satisfying (t 6 7) 3 +inf.0) (test-equal (generate-term l #:satisfying (t 6 7) = 3 +inf.0)
#f) #f)
(test-equal (generate-term l #:satisfying (t 6 7) 2 +inf.0) (test-equal (generate-term l #:satisfying (t 6 7) = 2 +inf.0)
#f) #f)
(test-equal (generate-term l #:satisfying (t 6 7) 1 +inf.0) (test-equal (generate-term l #:satisfying (t 6 7) = 1 +inf.0)
#f)) #f))
#; #;

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

@ -1322,15 +1322,13 @@
(test (generate-term nats (test (generate-term nats
#:satisfying #:satisfying
(sum z z) (sum z z) = n
n
5) 5)
'((sum z z) = z)) '((sum z z) = z))
(test (generate-term nats (test (generate-term nats
#:satisfying #:satisfying
(sum (s z) (s z)) (sum (s z) (s z)) = n
n
5) 5)
'((sum (s z) (s z)) = (s (s z))))) '((sum (s z) (s z)) = (s (s z)))))