diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index f8e51dcdd2..d6bca72153 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -8,8 +8,6 @@ (reset-count) - - ;; to-table : hash-table -> assoc ;; extracts the hash-table's mapping in a deterministic way (define (to-table ht) @@ -136,7 +134,7 @@ ;; Generate (λ (x) x) (test - (generate + (generate/decisions lc e 1 0 (decisions #:var (list (λ _ 'x) (λ _'x)) #:nt (patterns third first first first))) @@ -144,7 +142,7 @@ ;; Generate pattern that's not a non-terminal (test - (generate + (generate/decisions lc (x x x_1 x_1) 1 0 (decisions #:var (list (λ _ 'x) (λ _ 'y)))) '(x x y y)) @@ -152,7 +150,7 @@ ;; Minimum rhs is chosen with zero size (test (let/ec k - (generate + (generate/decisions lc e 0 0 (decisions #:nt (list (λ (prods . _) (k (map rhs-pattern prods))))))) '(x)) @@ -161,7 +159,7 @@ (let ([size 5]) (test (let/ec k - (generate + (generate/decisions lc e size 0 (decisions #:nt (list (λ (prods . _) (cadr prods)) (λ (p b s) (k s)))))) (sub1 size)))) @@ -176,7 +174,7 @@ (let* ([x null] [prepend! (λ (c l b a) (begin (set! x (cons (car b) x)) 'x))]) (test (begin - (generate lang a 5 0 (decisions #:var (list (λ _ 'x) prepend! prepend!))) + (generate/decisions lang a 5 0 (decisions #:var (list (λ _ 'x) prepend! prepend!))) x) '(x x)))) @@ -187,7 +185,7 @@ (x (variable-except λ))) (test (exn:fail-message - (generate + (generate/decisions postfix e 2 0 (decisions #:var (list (λ _ 'x) (λ _ 'y)) #:nt (patterns third second first first)))) @@ -198,7 +196,7 @@ (define-language var (e (variable-except x y))) (test - (generate + (generate/decisions var e 2 0 (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'z)))) 'z)) @@ -215,25 +213,25 @@ (n number) (z 4)) (test - (generate + (generate/decisions lang a 2 0 (decisions #:num (build-list 3 (λ (n) (λ (_) n))) #:seq (list (λ () 2) (λ () 3) (λ () 1)))) `(0 1 2 "foo" "foo" "foo" "bar" #t)) - (test (generate lang b 5 0 (decisions #:seq (list (λ () 0)))) + (test (generate/decisions lang b 5 0 (decisions #:seq (list (λ () 0)))) null) - (test (generate lang c 5 0 (decisions #:seq (list (λ () 0)))) + (test (generate/decisions lang c 5 0 (decisions #:seq (list (λ () 0)))) null) - (test (generate lang d 5 0 (decisions #:seq (list (λ () 2)))) + (test (generate/decisions lang d 5 0 (decisions #:seq (list (λ () 2)))) '(4 4 4 4 (4 4) (4 4))) - (test (exn:fail-message (generate lang e 5 0)) + (test (exn:fail-message (generate lang e 5)) #rx"generate: unable to generate pattern \\(n_1 ..._!_1 n_2 ..._!_1 \\(n_1 n_2\\) ..._3\\)") - (test (generate lang f 5 0 (decisions #:seq (list (λ () 0)))) null) - (test (generate lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 + (test (generate/decisions lang f 5 0 (decisions #:seq (list (λ () 0)))) null) + (test (generate/decisions lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 (decisions #:seq (list (λ () 2) (λ () 3) (λ () 4) (λ () 2) (λ () 3) (λ () 4) (λ () 2) (λ () 3) (λ () 4) (λ () 1) (λ () 3)))) '((0 0 0) (0 0 0 0) (1 1 1))) - (test (generate lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 + (test (generate/decisions lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 (decisions #:seq (list (λ () 2) (λ () 3) (λ () 4) (λ () 2) (λ () 3) (λ () 5)))) '((0 0 0) (0 0 0 0) (1 1 1) (1 1 1 1 1)))) @@ -247,7 +245,7 @@ ;; x and y bound in body (test (let/ec k - (generate + (generate/decisions lc e 10 0 (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b))) #:nt (patterns first first first third first) @@ -257,7 +255,7 @@ (let () (define-language lang (e (variable-prefix pf))) (test - (generate + (generate/decisions lang e 5 0 (decisions #:var (list (λ _ 'x)))) 'pfx)) @@ -271,7 +269,7 @@ (define-language lang (e number (e_1 e_2 e e_1 e_2))) (test - (generate + (generate/decisions lang e 5 0 (decisions #:nt (patterns second first first first) #:num (list (λ _ 2) (λ _ 3) (λ _ 4)))) @@ -283,7 +281,7 @@ (x variable)) (test (let/ec k - (generate + (generate/decisions lang e 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))))) '(x))) @@ -294,17 +292,17 @@ (b (c_!_1 c_!_1 c_!_1)) (c 1 2)) (test - (generate + (generate/decisions lang a 5 0 (decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2)))) '(1 1 2)) (test - (generate + (generate/decisions lang (number_!_1 number_!_2 number_!_1) 5 0 (decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2)))) '(1 1 2)) (test - (exn:fail-message (generate lang b 5000 0)) + (exn:fail-message (generate lang b 5000)) #rx"unable")) (let () @@ -313,7 +311,7 @@ (f foo bar)) (test (let/ec k - (generate + (generate/decisions lang e 5 0 (decisions #:str (list (λ (c l a) (k (cons (sort c char<=?) (sort l string<=?)))))))) (cons '(#\a #\b #\f #\o #\r) @@ -327,28 +325,28 @@ (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 (generate lang (side-condition a (odd? (term a))) 5 0) 43) - (test (exn:fail-message (generate lang c 5 0)) + (test (generate lang b 5) 43) + (test (generate lang (side-condition a (odd? (term a))) 5) 43) + (test (exn:fail-message (generate lang c 5)) #rx"unable to generate") (test ; binding works for with side-conditions failure/retry (let/ec k - (generate + (generate/decisions 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 + (generate/decisions lang e 5 0 (decisions #:var (list (λ _ 'x) (λ _ '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 + (generate/decisions lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0 (decisions #:var (list (λ _ 'x) (λ _ 'y)))) 'y) (test ; bindings within ellipses collected properly (let/ec k - (generate lang (side-condition (((number_1 3) ...) ...) (k (term ((number_1 ...) ...)))) 5 0 + (generate/decisions lang (side-condition (((number_1 3) ...) ...) (k (term ((number_1 ...) ...)))) 5 0 (decisions #:seq (list (λ () 2) (λ () 3) (λ () 4)) #:num (build-list 7 (λ (n) (λ (_) n)))))) '((0 1 2) (3 4 5 6)))) @@ -360,9 +358,9 @@ (c (side-condition (name x d) (zero? (term x)))) (d 2 1 0) (e ((side-condition (name d_1 d) (zero? (term d_1))) d_1))) - (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 a 5) 4) + (test (generate lang c 5) 0) + (test (generate lang e 5) '(0 0))) (let () (define-language lang @@ -380,28 +378,28 @@ (y variable)) (test - (generate + (generate/decisions lang (in-hole A number ) 5 0 (decisions #:nt (patterns second second first first third first second first first) #:num (build-list 5 (λ (x) (λ (_) x))))) '(+ (+ 1 2) (+ 0 (+ 3 4)))) - (test (generate lang (in-hole (in-hole (1 hole) hole) 5) 5 0) '(1 5)) - (test (generate lang (hole 4) 5 0) (term (hole 4))) - (test (generate lang (variable_1 (in-hole C variable_1)) 5 0 + (test (generate lang (in-hole (in-hole (1 hole) hole) 5) 5) '(1 5)) + (test (generate lang (hole 4) 5) (term (hole 4))) + (test (generate/decisions 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)) 5 0 + (test (generate/decisions lang (variable_!_1 (in-hole C variable_!_1)) 5 0 (decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'x) (λ _ 'y)))) '(x y)) - (test (let/ec k (generate lang d 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))))) + (test (let/ec k (generate/decisions lang d 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))))) '(x)) - (test (generate lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2)))) + (test (generate/decisions lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2)))) '((2 (1 1)) 1)) - (test (generate lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0)))) + (test (generate/decisions lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0)))) '(1 0)) - (test (generate lang h 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 3)))) + (test (generate/decisions lang h 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 3)))) '((2 ((3 (2 1)) 3)) 1))) (let () @@ -409,7 +407,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/decisions lc x 5 0 (decisions #:var (list (λ _ 'λ) (λ _ '+) (λ _ 'x)))) 'x)) (let () @@ -422,8 +420,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/decisions four any 5 0 (decisions #:any (list (λ _ (values four 'e))))) 4) + (test (generate/decisions four any 5 0 (decisions #:any (list (λ _ (values sexp 'sexp))) #:nt (patterns fifth second second second) #:seq (list (λ _ 3)) @@ -434,7 +432,7 @@ (let () (define-language lang (e (hide-hole (in-hole ((hide-hole hole) hole) 1)))) - (test (generate lang e 5 0) (term (hole 1)))) + (test (generate lang e 5) (term (hole 1)))) (define (output-error-port thunk) (let ([port (open-output-string)]) @@ -448,7 +446,7 @@ (e x (e e) v) (v (λ (x) e)) (x variable-not-otherwise-mentioned)) - (test (generate lang (cross e) 3 0 + (test (generate/decisions lang (cross e) 3 0 (decisions #:nt (patterns fourth first first second first first first) #:var (list (λ _ 'x) (λ _ 'y)))) (term (λ (x) (hole y))))) diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index 31e0168625..3ce57de2e6 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -114,7 +114,7 @@ To do a better job of not generating programs with free variables, (error 'generate "unable to generate pattern ~s in ~s attempts" (unparse-pattern pat) generation-retries)) -(define (generate* lang pat size attempt [decisions@ random-decisions@]) +(define (generate* lang pat size [decisions@ random-decisions@]) (define-values/invoke-unit decisions@ (import) (export decisions^)) @@ -122,7 +122,7 @@ To do a better job of not generating programs with free variables, (define lang-chars (unique-chars lang-lits)) (define base-table (find-base-cases lang)) - (define (generate-nt name fvt-id bound-vars size in-hole state) + (define (generate-nt name fvt-id bound-vars size attempt in-hole state) (let*-values ([(nt) (findf (λ (nt) (eq? name (nt-name nt))) (append (compiled-lang-lang lang) @@ -136,7 +136,7 @@ To do a better job of not generating programs with free variables, [(term _) (generate/pred (rhs-pattern rhs) - (λ (pat) (((generate-pat bound-vars (max 0 (sub1 size))) pat in-hole) nt-state)) + (λ (pat) (((generate-pat bound-vars (max 0 (sub1 size)) attempt) pat in-hole) nt-state)) (λ (_ env) (mismatches-satisfied? env)))]) (values term (extend-found-vars fvt-id term state)))) @@ -211,8 +211,8 @@ To do a better job of not generating programs with free variables, (define (fvt-entry binds) (make-found-vars (binds-binds binds) (binds-source binds) '() #f)) - (define (((generate-pat bound-vars size) pat in-hole) state) - (define recur (generate-pat bound-vars size)) + (define (((generate-pat bound-vars size attempt) pat in-hole) state) + (define recur (generate-pat bound-vars size attempt)) (define (recur/pat pat) ((recur pat in-hole) state)) (match pat @@ -240,22 +240,22 @@ To do a better job of not generating programs with free variables, [`(hide-hole ,pattern) ((recur pattern the-hole) state)] [`any (let*-values ([(lang nt) ((next-any-decision) lang)] - [(term _) (generate* lang nt size attempt decisions@)]) + [(term _) ((generate* lang nt size decisions@) attempt)]) (values term state))] [(? (is-nt? lang)) - (generate-nt pat pat bound-vars size in-hole state)] + (generate-nt pat pat bound-vars size attempt in-hole state)] [(struct binder ((and name (or (? (is-nt? lang) nt) (app (symbol-match named-nt-rx) (? (is-nt? lang) nt)))))) - (generate/prior pat state (λ () (generate-nt nt name bound-vars size in-hole state)))] + (generate/prior pat state (λ () (generate-nt nt name bound-vars size attempt in-hole state)))] [(struct binder ((or (? built-in? b) (app (symbol-match named-nt-rx) (? built-in? b))))) (generate/prior pat state (λ () (recur/pat b)))] [(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? (is-nt? lang) nt))))) - (let-values ([(term state) (generate-nt nt pat bound-vars size in-hole state)]) + (let-values ([(term state) (generate-nt nt pat bound-vars size attempt in-hole state)]) (values term (set-env state pat term)))] [(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? built-in? b))))) (let-values ([(term state) (recur/pat b)]) (values term (set-env state pat term)))] [`(cross ,(? symbol? cross-nt)) - (generate-nt cross-nt #f bound-vars size in-hole state)] + (generate-nt cross-nt #f bound-vars size attempt in-hole state)] [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat state)] [(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest) (let*-values ([(length) (let ([prior (hash-ref (state-env state) class #f)]) @@ -306,14 +306,15 @@ To do a better job of not generating programs with free variables, (state-fvt state)) (state-env state))) - (let-values ([(term state) - (generate/pred - pat - (λ (pat) - (((generate-pat null size) pat the-hole) - (make-state null #hash()))) - (λ (_ env) (mismatches-satisfied? env)))]) - (values term (bindings (state-env state))))) + (λ (attempt) + (let-values ([(term state) + (generate/pred + pat + (λ (pat) + (((generate-pat null size attempt) pat the-hole) + (make-state null #hash()))) + (λ (_ env) (mismatches-satisfied? env)))]) + (values term (bindings (state-env state)))))) ;; find-base-cases : compiled-language -> hash-table (define (find-base-cases lang) @@ -559,41 +560,46 @@ To do a better job of not generating programs with free variables, (with-syntax ([(name ...) names] [(name/ellipses ...) names/ellipses]) (syntax/loc stx - (let loop ([remaining attempts]) - (if (zero? remaining) - #t - (let ([attempt (add1 (- attempts remaining))]) - (let-values ([(term bindings) (generate/bindings lang pat size attempt)]) - (term-let ([name/ellipses (lookup-binding bindings 'name)] ...) - (if (with-handlers - ([exn:fail? (λ (exn) (error 'check "term ~s raises ~s" term exn))]) - property) - (loop (sub1 remaining)) - (fprintf (current-error-port) - "failed after ~s attempts: ~s" - attempt term))))))))))])) + (let ([generator (term-generator lang pat size random-decisions@)]) + (let loop ([remaining attempts]) + (if (zero? remaining) + #t + (let ([attempt (add1 (- attempts remaining))]) + (let-values ([(term bindings) (generator attempt)]) + (term-let ([name/ellipses (lookup-binding bindings 'name)] ...) + (if (with-handlers + ([exn:fail? (λ (exn) (error 'check "term ~s raises ~s" term exn))]) + property) + (loop (sub1 remaining)) + (fprintf (current-error-port) + "failed after ~s attempts: ~s" + attempt term)))))))))))])) -(define-syntax (generate stx) - (syntax-case stx () - [(_ . args) - (quasisyntax - (let-values ([(term bindings) (generate/bindings #,@#'args)]) - term))])) - -(define-syntax (generate/bindings stx) - (syntax-case stx () +(define-syntax generate + (syntax-rules () [(_ lang pat size attempt) - (syntax (generate/bindings lang pat size attempt random-decisions@))] + (let-values ([(term _) ((term-generator lang pat size random-decisions@) attempt)]) + term)] + [(_ lang pat size) (generate lang pat size 0)])) + +(define-syntax generate/decisions + (syntax-rules () [(_ lang pat size attempt decisions@) + (let-values ([(term _) ((term-generator lang pat size decisions@) attempt)]) + term)])) + +(define-syntax (term-generator stx) + (syntax-case stx () + [(_ lang pat size decisions@) (with-syntax ([pattern (rewrite-side-conditions/check-errs (language-id-nts #'lang 'generate) 'generate #t #'pat)]) - (syntax + (syntax/loc stx (generate* (parse-language lang) (reassign-classes (parse-pattern `pattern lang 'top-level)) - size attempt decisions@)))])) + size decisions@)))])) (define-signature decisions^ (next-variable-decision @@ -617,7 +623,7 @@ To do a better job of not generating programs with free variables, pick-nt unique-chars pick-any sexp generate parse-pattern class-reassignments reassign-classes unparse-pattern (struct-out ellipsis) (struct-out mismatch) (struct-out class) - (struct-out binder)) + (struct-out binder) generate/decisions) (provide/contract [find-base-cases (-> compiled-lang? hash?)]) \ No newline at end of file