Rewrote `generate' as a macro that rewrites the side-conditions in its
target pattern, removed `try', and improved `check'. svn: r11074
This commit is contained in:
Casey Klein
parent
317a8aae20
commit
b144254b58
|
|
@ -107,10 +107,10 @@
|
|||
[(equal? (rhs-pattern (car prods)) pat) (car prods)]
|
||||
[else (rhs-matching pat (cdr prods))]))
|
||||
|
||||
(define-syntax expect-exn
|
||||
(define-syntax exn:fail-message
|
||||
(syntax-rules ()
|
||||
[(_ expr)
|
||||
(with-handlers ([exn:fail? (λ (x) x)])
|
||||
(with-handlers ([exn:fail? exn-message])
|
||||
(begin
|
||||
expr
|
||||
(let ()
|
||||
|
|
@ -121,7 +121,7 @@
|
|||
(define-language l (a (a b) (a b c) c))
|
||||
(test (rhs-matching '(a b c) (nt-rhs (car (compiled-lang-lang l))))
|
||||
(cadr (nt-rhs (car (compiled-lang-lang l)))))
|
||||
(test (exn-message (expect-exn (rhs-matching '(a c) (nt-rhs (car (compiled-lang-lang l))))))
|
||||
(test (exn:fail-message (rhs-matching '(a c) (nt-rhs (car (compiled-lang-lang l)))))
|
||||
#rx"no rhs matching"))
|
||||
|
||||
(define (select-pattern pat)
|
||||
|
|
@ -139,7 +139,7 @@
|
|||
(let ([iter (iterator 'test-iterator '(a b))])
|
||||
(test (iter) 'a)
|
||||
(test (iter) 'b)
|
||||
(test (exn-message (expect-exn (iter))) #rx"empty"))
|
||||
(test (exn:fail-message (iter)) #rx"empty"))
|
||||
|
||||
(define (decisions #:var [var pick-var]
|
||||
#:nt [nt pick-nt]
|
||||
|
|
@ -166,7 +166,7 @@
|
|||
;; Generate (λ (x) x)
|
||||
(test
|
||||
(generate
|
||||
lc 'e 1 0
|
||||
lc e 1 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _'x))
|
||||
#:nt (patterns '(λ (x) e)
|
||||
'(variable-except λ)
|
||||
|
|
@ -177,7 +177,7 @@
|
|||
;; Generate pattern that's not a non-terminal
|
||||
(test
|
||||
(generate
|
||||
lc '(x_1 x_1) 1 0
|
||||
lc (x_1 x_1) 1 0
|
||||
(decisions #:var (list (λ _ 'x))))
|
||||
'(x x))
|
||||
|
||||
|
|
@ -185,7 +185,7 @@
|
|||
(test
|
||||
(let/ec k
|
||||
(generate
|
||||
lc 'e 0 0
|
||||
lc e 0 0
|
||||
(decisions #:nt (list (λ (prods . _) (k (map rhs-pattern prods)))))))
|
||||
'(x))
|
||||
|
||||
|
|
@ -194,7 +194,7 @@
|
|||
(test
|
||||
(let/ec k
|
||||
(generate
|
||||
lc 'e size 0
|
||||
lc e size 0
|
||||
(decisions #:nt (list (select-pattern 'x) (λ (p b s) (k s))))))
|
||||
(sub1 size))))
|
||||
|
||||
|
|
@ -204,15 +204,14 @@
|
|||
(e (e e) x (e (x) λ) #:binds x e)
|
||||
(x (variable-except λ)))
|
||||
(test
|
||||
(exn-message
|
||||
(expect-exn
|
||||
(exn:fail-message
|
||||
(generate
|
||||
postfix 'e 2 0
|
||||
postfix e 2 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'y))
|
||||
#:nt (patterns '(e (x) λ)
|
||||
'x
|
||||
'(variable-except λ)
|
||||
'(variable-except λ))))))
|
||||
'(variable-except λ)))))
|
||||
#rx"kludge"))
|
||||
|
||||
;; variable-except pattern
|
||||
|
|
@ -221,7 +220,7 @@
|
|||
(e (variable-except x y)))
|
||||
(test
|
||||
(generate
|
||||
var 'e 2 0
|
||||
var e 2 0
|
||||
(decisions #:nt (patterns '(variable-except x y))
|
||||
#:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'z))))
|
||||
'z))
|
||||
|
|
@ -231,7 +230,7 @@
|
|||
(e (number number ... "foo" ... "bar" #t ...)))
|
||||
(test
|
||||
(generate
|
||||
lang 'e 2 0
|
||||
lang e 2 0
|
||||
(decisions #:num (build-list 3 (λ (n) (λ (_) n)))
|
||||
#:seq (list (λ () 2) (λ () 3) (λ () 1))))
|
||||
`(0 1 2 "foo" "foo" "foo" "bar" #t)))
|
||||
|
|
@ -247,7 +246,7 @@
|
|||
(test
|
||||
(let/ec k
|
||||
(generate
|
||||
lc 'e 10 0
|
||||
lc e 10 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b)))
|
||||
#:nt (patterns '(λ (x ...) e)
|
||||
'(variable-except λ)
|
||||
|
|
@ -261,7 +260,7 @@
|
|||
(define-language lang (e (variable-prefix pf)))
|
||||
(test
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
lang e 5 0
|
||||
(decisions #:var (list (λ _ 'x))
|
||||
#:nt (patterns '(variable-prefix pf))))
|
||||
'pfx))
|
||||
|
|
@ -278,7 +277,7 @@
|
|||
(e number (e_1 e_2 e e_1 e_2)))
|
||||
(test
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
lang e 5 0
|
||||
(decisions #:nt (patterns '(e_1 e_2 e e_1 e_2)
|
||||
'number
|
||||
'number
|
||||
|
|
@ -294,7 +293,7 @@
|
|||
(test
|
||||
(let/ec k
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
lang e 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))
|
||||
#:nt (patterns '(x x_1 x_1)
|
||||
'variable
|
||||
|
|
@ -303,7 +302,7 @@
|
|||
(test
|
||||
(let/ec k
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
lang e 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))
|
||||
#:nt (patterns '(x variable_1) 'variable))))
|
||||
'(x)))
|
||||
|
|
@ -313,7 +312,7 @@
|
|||
(e (number_!_1 number_!_2 number_!_1 number_!_2)))
|
||||
(test
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
lang e 5 0
|
||||
(decisions #:nt (patterns '(number_!_1 number_!_2 number_!_1 number_!_2))
|
||||
#:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2) (λ _ 3))))
|
||||
'(1 1 2 3)))
|
||||
|
|
@ -323,7 +322,7 @@
|
|||
(a (b_!_1 b_!_1 b_!_1))
|
||||
(b 1 2))
|
||||
(test
|
||||
(exn-message (expect-exn (generate lang 'a 5000 0)))
|
||||
(exn:fail-message (generate lang a 5000 0))
|
||||
#rx"unable"))
|
||||
|
||||
(let ()
|
||||
|
|
@ -332,7 +331,7 @@
|
|||
(x variable))
|
||||
(test
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
lang e 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'y) (λ _ 'z))
|
||||
#:nt (patterns '(x_!_1 ...)
|
||||
'variable
|
||||
|
|
@ -350,7 +349,7 @@
|
|||
(test
|
||||
(let/ec k
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
lang e 5 0
|
||||
(decisions #:str (list (λ (c l a) (k (cons (sort c char<=?) (sort l string<=?))))))))
|
||||
(cons '(#\g #\i #\n #\r #\s #\t)
|
||||
'("string"))))
|
||||
|
|
@ -363,20 +362,24 @@
|
|||
(d (side-condition (x_1 x_1 x) (not (eq? (term x_1) 'x))) #:binds x_1 x)
|
||||
(e (side-condition (x_1 x_!_2 x_!_2) (not (eq? (term x_1) 'x))))
|
||||
(x variable))
|
||||
(test (generate lang 'b 5 0) 43)
|
||||
(test (exn-message (expect-exn (generate lang 'c 5 0)))
|
||||
(test (generate lang b 5 0) 43)
|
||||
(test (exn:fail-message (generate lang c 5 0))
|
||||
#rx"unable to generate")
|
||||
(test ; binding works for with side-conditions failure/retry
|
||||
(let/ec k
|
||||
(generate
|
||||
lang 'd 5 0
|
||||
lang d 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b))))))
|
||||
'(y))
|
||||
(test ; mismatch patterns work with side-condition failure/retry
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
lang e 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'y) (λ _ 'x) (λ _ 'y))))
|
||||
'(y x y)))
|
||||
'(y x y))
|
||||
(test ; generate compiles side-conditions in pattern
|
||||
(generate lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'y))))
|
||||
'y))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
|
|
@ -386,10 +389,10 @@
|
|||
(d 2 1 0)
|
||||
(e ((side-condition (name d_1 d) (zero? (term d_1))) d_1))
|
||||
(f ((side-condition d_1 (zero? (term d_1))) (name d_1 d))))
|
||||
(test (generate lang 'a 5 0) 4)
|
||||
(test (generate lang 'c 5 0) 0)
|
||||
(test (generate lang 'e 5 0) '(0 0))
|
||||
(test (generate lang 'f 5 0) '(0 0)))
|
||||
(test (generate lang a 5 0) 4)
|
||||
(test (generate lang c 5 0) 0)
|
||||
(test (generate lang e 5 0) '(0 0))
|
||||
(test (generate lang f 5 0) '(0 0)))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
|
|
@ -402,22 +405,22 @@
|
|||
(y variable))
|
||||
(test
|
||||
(generate
|
||||
lang '(in-hole A number ) 5 0
|
||||
lang (in-hole A number ) 5 0
|
||||
(decisions
|
||||
#:nt (patterns '(+ a A) '(+ a a) 'number 'number '(+ A a) 'hole '(+ a a) 'number 'number)
|
||||
#:num (build-list 5 (λ (x) (λ (_) x)))))
|
||||
'(+ (+ 0 1) (+ 2 (+ 3 4))))
|
||||
(test (generate lang '(in-named-hole h B 3) 5 0) '(6 3))
|
||||
(test (generate lang '(in-hole (in-hole ((in-hole hole 4) hole) 3) 5) 5 0) '(4 3))
|
||||
(test (generate lang 'hole 5 0) (term hole))
|
||||
(test (generate lang '(hole h) 5 0) (term (hole h)))
|
||||
(test (generate lang '(variable_1 (in-hole C variable_1)) 5 0
|
||||
(test (generate lang (in-named-hole h B 3) 5 0) '(6 3))
|
||||
(test (generate lang (in-hole (in-hole ((in-hole hole 4) hole) 3) 5) 5 0) '(4 3))
|
||||
(test (generate lang hole 5 0) (term hole))
|
||||
(test (generate lang (hole h) 5 0) (term (hole h)))
|
||||
(test (generate lang (variable_1 (in-hole C variable_1)) 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x))))
|
||||
'(x x))
|
||||
(test (generate lang '(variable_!_1 (in-hole C variable_!_1) variable_!_1) 5 0
|
||||
(test (generate lang (variable_!_1 (in-hole C variable_!_1) variable_!_1) 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'y) (λ _ 'z))))
|
||||
'(x y z))
|
||||
(test (let/ec k (generate lang 'd 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))))))
|
||||
(test (let/ec k (generate lang d 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))))))
|
||||
'(x)))
|
||||
|
||||
(let ()
|
||||
|
|
@ -425,7 +428,7 @@
|
|||
(e (e e) (+ e e) x v)
|
||||
(v (λ (x) e) number)
|
||||
(x variable-not-otherwise-mentioned))
|
||||
(test (generate lc 'x 5 0 (decisions #:var (list (λ _ 'λ) (λ _ '+) (λ _ 'x))))
|
||||
(test (generate lc x 5 0 (decisions #:var (list (λ _ 'λ) (λ _ '+) (λ _ 'x))))
|
||||
'x))
|
||||
|
||||
(let ()
|
||||
|
|
@ -438,8 +441,8 @@
|
|||
(list four 'f))
|
||||
(test (call-with-values (λ () (pick-any four (make-random (list 1)))) list)
|
||||
(list sexp 'sexp))
|
||||
(test (generate four 'any 5 0 (decisions #:any (list (λ _ (values four 'e))))) 4)
|
||||
(test (generate four 'any 5 0
|
||||
(test (generate four any 5 0 (decisions #:any (list (λ _ (values four 'e))))) 4)
|
||||
(test (generate four any 5 0
|
||||
(decisions #:any (list (λ _ (values sexp 'sexp)))
|
||||
#:nt (list (select-pattern '(sexp ...))
|
||||
(select-pattern 'string)
|
||||
|
|
@ -453,7 +456,7 @@
|
|||
(let ()
|
||||
(define-language lang
|
||||
(e (hide-hole (in-hole ((hide-hole hole) hole) 1))))
|
||||
(test (generate lang 'e 5 0) (term ((hole #f) 1))))
|
||||
(test (generate lang e 5 0) (term ((hole #f) 1))))
|
||||
|
||||
(define (output-error-port thunk)
|
||||
(let ([port (open-output-string)])
|
||||
|
|
@ -465,12 +468,11 @@
|
|||
(define-language lang
|
||||
(d 5)
|
||||
(e e 4))
|
||||
(test (output-error-port (λ () (try lang 'e (λ (x) #t))))
|
||||
#rx"No failures")
|
||||
(test (output-error-port (λ () (try lang 'e (λ (x) #f))))
|
||||
#rx"FAILED")
|
||||
(test (output-error-port
|
||||
(λ () (check lang (d_1 e d_2) (equal? '(5 5 4) (term (d_2 d_1 e))) 1 5)))
|
||||
#rx"No failures"))
|
||||
(test (check lang () 2 0 #f) "failed after 1 attempts: ()")
|
||||
(test (check lang () 2 0 #t) #t)
|
||||
(test (check lang ([x d] [y e]) 2 0 (and (eq? (term x) 5) (eq? (term y) 4))) #t)
|
||||
(test (check lang ([x d] [y e]) 2 0 #f) "failed after 1 attempts: ((x 5) (y 4))")
|
||||
(test (exn:fail-message (check lang ([x d]) 2 0 (error 'pred-raised)))
|
||||
#rx"term \\(\\(x 5\\)\\) raises"))
|
||||
|
||||
(print-tests-passed 'rg-test.ss)
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ To do a better job of not generating programs with free variables,
|
|||
"reduction-semantics.ss"
|
||||
"underscore-allowed.ss"
|
||||
"term.ss"
|
||||
(for-syntax "rewrite-side-conditions.ss")
|
||||
mrlib/tex-table)
|
||||
|
||||
(define random-numbers '(0 1 -1 17 8))
|
||||
|
|
@ -132,7 +133,7 @@ To do a better job of not generating programs with free variables,
|
|||
;; used in generating the `any' pattern
|
||||
(define-language sexp (sexp variable string number hole (sexp ...)))
|
||||
|
||||
(define (generate lang nt size attempt [decisions@ random-decisions@])
|
||||
(define (generate* lang nt size attempt [decisions@ random-decisions@])
|
||||
(define-values/invoke-unit decisions@
|
||||
(import) (export decisions^))
|
||||
|
||||
|
|
@ -197,8 +198,6 @@ To do a better job of not generating programs with free variables,
|
|||
(define (condition-bindings bindings)
|
||||
(make-bindings (hash-map bindings (λ (name exp) (make-bind name exp)))))
|
||||
(generate/retry (λ _ (condition (condition-bindings bindings))) pattern)]
|
||||
[`(side-condition ,pattern ,uncompiled-condition)
|
||||
(error 'generate "side-condition not compiled: ~s" pat)]
|
||||
[`(name ,(? symbol? id) ,p)
|
||||
(define (generate/record)
|
||||
(let ([term (loop p holes)])
|
||||
|
|
@ -214,7 +213,7 @@ To do a better job of not generating programs with free variables,
|
|||
[`(hide-hole ,pattern) (loop pattern (make-immutable-hasheq null))]
|
||||
[`any
|
||||
(let-values ([(lang nt) ((next-any-decision) lang)])
|
||||
(generate lang nt size attempt decisions@))]
|
||||
(generate* lang nt size attempt decisions@))]
|
||||
[(and (? symbol?) (? (λ (x) (or (is-nt? lang x) (underscored-built-in? x)))))
|
||||
(define ((generate-nt/underscored decorated) undecorated)
|
||||
(let* ([vars (append (extract-bound-vars decorated found-vars-table) bound-vars)]
|
||||
|
|
@ -368,26 +367,35 @@ To do a better job of not generating programs with free variables,
|
|||
(not (false? (and (memq #\_ (string->list (symbol->string sym)))
|
||||
(memq (symbol->nt sym) underscore-allowed)))))
|
||||
|
||||
(define (try lang nt pred? #:attempts [attempts 1000] #:size [size 6])
|
||||
(let loop ([i attempts])
|
||||
(if (zero? i)
|
||||
(fprintf (current-error-port) "No failures in ~a attempts\n" attempts)
|
||||
(let ([t (generate lang nt size (- attempts i))])
|
||||
(if (with-handlers ([exn:fail? (λ (exn) (error 'try "checking ~s: ~s" t exn))])
|
||||
(pred? t))
|
||||
(loop (- i 1))
|
||||
(begin
|
||||
(fprintf (current-error-port) "FAILED after ~s attempt(s)!\n" (add1 (- attempts i)))
|
||||
(pretty-print t (current-error-port))))))))
|
||||
|
||||
(define-syntax check
|
||||
(syntax-rules ()
|
||||
[(_ lang (id ...) expr attempts size)
|
||||
(try lang (quote (id ...))
|
||||
(λ (pat)
|
||||
(let-values ([(id ...) (apply values pat)])
|
||||
(term-let ([id id] ...) expr)))
|
||||
#:attempts attempts #:size size)]))
|
||||
[(_ lang ([id pat] ...) attempts size property)
|
||||
(let loop ([remaining attempts])
|
||||
(if (zero? remaining)
|
||||
#t
|
||||
(let ([attempt (add1 (- attempts remaining))])
|
||||
(term-let
|
||||
([id (generate lang pat size attempt)] ...)
|
||||
(let ([generated (term ((,'id id) ...))])
|
||||
(if (with-handlers
|
||||
([exn:fail? (λ (exn) (error 'check "term ~s raises ~s" generated exn))])
|
||||
property)
|
||||
(loop (sub1 remaining))
|
||||
(format "failed after ~s attempts: ~s"
|
||||
attempt generated)))))))]))
|
||||
|
||||
(define-syntax (generate stx)
|
||||
(syntax-case stx ()
|
||||
[(_ lang pat size attempt)
|
||||
(syntax (generate lang pat size attempt random-decisions@))]
|
||||
[(_ lang pat size attempt decisions@)
|
||||
(with-syntax ([rewritten
|
||||
(rewrite-side-conditions/check-errs
|
||||
(language-id-nts #'lang 'generate)
|
||||
'generate
|
||||
#f
|
||||
#'pat)])
|
||||
(syntax (generate* lang `rewritten size attempt decisions@)))]))
|
||||
|
||||
(define-signature decisions^
|
||||
(next-variable-decision
|
||||
|
|
@ -411,12 +419,8 @@ To do a better job of not generating programs with free variables,
|
|||
|
||||
(provide pick-from-list pick-var pick-length min-prods decisions^
|
||||
is-nt? lang-literals pick-char random-string pick-string
|
||||
check pick-nt unique-chars pick-any sexp)
|
||||
check pick-nt unique-chars pick-any sexp generate)
|
||||
|
||||
(provide/contract
|
||||
[generate any/c]
|
||||
[try (->* (compiled-lang? sexp? (-> any/c any))
|
||||
(#:attempts number? #:size number?)
|
||||
void?)]
|
||||
[find-base-cases (-> compiled-lang? hash?)])
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user