From b144254b58b2a6cca2582c41af9f4b2c4488eee6 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Mon, 4 Aug 2008 22:39:23 +0000 Subject: [PATCH] Rewrote `generate' as a macro that rewrites the side-conditions in its target pattern, removed `try', and improved `check'. svn: r11074 --- collects/redex/private/rg-test.ss | 104 +++++++++++++++--------------- collects/redex/private/rg.ss | 58 +++++++++-------- 2 files changed, 84 insertions(+), 78 deletions(-) diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index e01772bcad..cd583e7b65 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -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) diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index 7d0afcced6..a93a181260 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.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?)])