From ba4b0b630103551795741bfb537c0bd2c3d7260e Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Wed, 30 Jul 2008 00:46:30 +0000 Subject: [PATCH] - Fixed bug in `pick-char' and `random-string'. - Added support for hole and in-hole patterns. - Fixed infinite loop triggered by `any' pattern. - Removed schemeunit-test from run-all-tests.ss. svn: r10978 --- collects/redex/private/rg-test.ss | 140 +++++++++++++++++-------- collects/redex/private/rg.ss | 154 +++++++++++++++------------- collects/redex/private/run-tests.ss | 1 - 3 files changed, 181 insertions(+), 114 deletions(-) diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index 058aeaf397..f2e4890d92 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -5,7 +5,7 @@ "matcher.ss" "term.ss" "rg.ss") - + (reset-count) @@ -58,7 +58,8 @@ (let () (define-language lang - (a (side-condition "strin_g" #t) 1/2 #t)) + (a (side-condition "strin_g" #t) 1/2 #t) + (b ())) (let* ([literals (sort (lang-literals lang) string<=?)] [chars (sort (unique-chars literals) char<=?)]) (test literals '("1/2" "side-condition" "strin_g")) @@ -94,22 +95,40 @@ (test (pick-var chars lits null 0 (make-random '(0 0 1 1 2 1 0))) 'dcb) (test (pick-var chars lits '(x) 0 (make-random '(1 0))) 'x))) +(let () + (define-language empty) + (let* ([lits (sort (lang-literals empty) string<=?)] + [chars (sort (unique-chars lits) char<=?)]) + (test (pick-char 0 chars (make-random '(65))) #\a) + (test (random-string chars lits 1 0 (make-random '(65))) "a"))) + (define (rhs-matching pat prods) (cond [(null? prods) (error 'rhs-matching "no rhs matching ~s" pat)] [(equal? (rhs-pattern (car prods)) pat) (car prods)] [else (rhs-matching pat (cdr prods))])) +(define-syntax expect-exn + (syntax-rules () + [(_ expr) + (with-handlers ([exn:fail? (λ (x) x)]) + (begin + expr + (let () + (define-struct exn-not-raised ()) + (make-exn-not-raised))))])) + (let () (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 (with-handlers ([exn:fail? exn-message]) - (rhs-matching '(a c) (nt-rhs (car (compiled-lang-lang l))))) + (test (exn-message (expect-exn (rhs-matching '(a c) (nt-rhs (car (compiled-lang-lang l)))))) #rx"no rhs matching")) (define (select-pattern pat) (λ (prods . _) (rhs-matching pat prods))) +(define (patterns . ps) (map select-pattern ps)) + (define (iterator name items) (let ([bi (box items)]) (λ () @@ -120,7 +139,7 @@ (let ([iter (iterator 'test-iterator '(a b))]) (test (iter) 'a) (test (iter) 'b) - (test (with-handlers ([exn:fail? exn-message]) (iter)) #rx"empty")) + (test (exn-message (expect-exn (iter))) #rx"empty")) (define (decisions #:var [var pick-var] #:nt [nt pick-nt] @@ -147,10 +166,10 @@ (generate lc 'e 1 0 (decisions #:var (list (λ _ 'x) (λ _'x)) - #:nt (list (select-pattern '(λ (x) e)) - (select-pattern '(variable-except λ)) - (select-pattern 'x) - (select-pattern '(variable-except λ))))) + #:nt (patterns '(λ (x) e) + '(variable-except λ) + 'x + '(variable-except λ)))) '(λ (x) x)) ;; Generate pattern that's not a non-terminal @@ -183,14 +202,15 @@ (e (e e) x (e (x) λ) #:binds x e) (x (variable-except λ))) (test - (with-handlers ([exn:fail? exn-message]) + (exn-message + (expect-exn (generate postfix 'e 2 0 (decisions #:var (list (λ _ 'x) (λ _ 'y)) - #:nt (list (select-pattern '(e (x) λ)) - (select-pattern 'x) - (select-pattern '(variable-except λ)) - (select-pattern '(variable-except λ)))))) + #:nt (patterns '(e (x) λ) + 'x + '(variable-except λ) + '(variable-except λ)))))) #rx"kludge")) ;; variable-except pattern @@ -200,7 +220,7 @@ (test (generate var 'e 2 0 - (decisions #:nt (list (select-pattern '(variable-except x y))) + (decisions #:nt (patterns '(variable-except x y)) #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'z)))) 'z)) @@ -227,11 +247,11 @@ (generate lc 'e 10 0 (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b))) - #:nt (list (select-pattern '(λ (x ...) e)) - (select-pattern '(variable-except λ)) - (select-pattern '(variable-except λ)) - (select-pattern 'x) - (select-pattern '(variable-except λ))) + #:nt (patterns '(λ (x ...) e) + '(variable-except λ) + '(variable-except λ) + 'x + '(variable-except λ)) #:seq (list (λ () 2))))) '(y x))) @@ -241,7 +261,7 @@ (generate lang 'e 5 0 (decisions #:var (list (λ _ 'x)) - #:nt (list (select-pattern '(variable-prefix pf))))) + #:nt (patterns '(variable-prefix pf)))) 'pfx)) (let () @@ -257,25 +277,33 @@ (test (generate lang 'e 5 0 - (decisions #:nt (list (select-pattern '(e_1 e_2 e e_1 e_2)) - (select-pattern 'number) - (select-pattern 'number) - (select-pattern 'number)) + (decisions #:nt (patterns '(e_1 e_2 e e_1 e_2) + 'number + 'number + 'number) #:num (list (λ _ 2) (λ _ 3) (λ _ 4)))) '(2 3 4 2 3))) (let () (define-language lang - (e (x x_1 x_1) #:binds x x_1) + (e (x x_1 x_1) #:binds x x_1 + (x variable_1) #:binds x variable_1) (x variable)) (test (let/ec k (generate lang 'e 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))) - #:nt (list (select-pattern '(x x_1 x_1)) - (select-pattern 'variable) - (select-pattern 'variable))))) + #:nt (patterns '(x x_1 x_1) + 'variable + 'variable)))) + '(x)) + (test + (let/ec k + (generate + lang 'e 5 0 + (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))) + #:nt (patterns '(x variable_1) 'variable)))) '(x))) (let () @@ -284,7 +312,7 @@ (test (generate lang 'e 5 0 - (decisions #:nt (list (select-pattern '(number_!_1 number_!_2 number_!_1 number_!_2))) + (decisions #:nt (patterns '(number_!_1 number_!_2 number_!_1 number_!_2)) #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2) (λ _ 3)))) '(1 1 2 3))) @@ -293,7 +321,7 @@ (a (b_!_1 b_!_1 b_!_1)) (b 1 2)) (test - (with-handlers ([exn:fail? exn-message]) (generate lang 'a 5000 0)) + (exn-message (expect-exn (generate lang 'a 5000 0))) #rx"unable")) (let () @@ -304,13 +332,13 @@ (generate lang 'e 5 0 (decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'y) (λ _ 'z)) - #:nt (list (select-pattern '(x_!_1 ...)) - (select-pattern 'variable) - (select-pattern 'variable) - (select-pattern 'variable) - (select-pattern 'variable) - (select-pattern 'variable) - (select-pattern 'variable)) + #:nt (patterns '(x_!_1 ...) + 'variable + 'variable + 'variable + 'variable + 'variable + 'variable) #:seq (list (λ _ 3)))) '(x y z))) @@ -334,8 +362,7 @@ (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 (with-handlers ([exn:fail? exn-message]) - (generate lang 'c 5 0)) + (test (exn-message (expect-exn (generate lang 'c 5 0))) #rx"unable to generate") (test ; binding works for with side-conditions failure/retry (let/ec k @@ -347,7 +374,7 @@ (generate lang 'e 5 0 (decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'y) (λ _ 'x) (λ _ 'y)))) - '(y x y))) + '(y x y))) (let () (define-language lang @@ -362,6 +389,35 @@ (test (generate lang 'e 5 0) '(0 0)) (test (generate lang 'f 5 0) '(0 0))) +(let () + (define-language lang + (a number (+ a a)) + (A hole (+ a A) (+ A a)) + (B (6 (hole h))) + (C hole) + (d (x (in-hole C y)) #:binds x y) + (x variable) + (y variable)) + (test + (generate + 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 + (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x)))) + '(x x)) + (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)))))) + '(x))) + (define (output-error-port thunk) (let ([port (open-output-string)]) (parameterize ([current-error-port port]) @@ -375,7 +431,7 @@ (test (output-error-port (λ () (try lang 'e (λ (x) #t)))) #rx"No failures") (test (output-error-port (λ () (try lang 'e (λ (x) #f)))) - "FAILED!\n4\n") + #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")) diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index a9321d3fec..8885b8a2de 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -86,23 +86,20 @@ To do a better job of not generating programs with free variables, (pick-from-list bound-vars random))) (define (pick-char attempt lang-chars [random random]) - (let ([lang (< attempt 50)] - [ascii (and (>= attempt ascii-chars-threshold) - (< attempt tex-chars-threshold))] - [tex (and (>= attempt tex-chars-threshold) - (< attempt chinese-chars-threshold))]) - (if (or lang (not (exotic-char? random))) - (pick-from-list lang-chars random) - (if (or ascii (not (exotic-char? random))) - (let ([i (random (- #x7E #x20 1))] - [_ (- (char->integer #\_) #x20)]) - (integer->char (+ #x20 (if (= i _) (add1 i) i)))) - (if (or tex (not (exotic-char? random))) - (car (string->list (pick-from-list (map cadr tex-shortcut-table) random))) - (integer->char (+ #x4E00 (random (- #x9FCF #x4E00))))))))) + (if (and (not (null? lang-chars)) + (or (< attempt ascii-chars-threshold) + (not (exotic-char? random)))) + (pick-from-list lang-chars random) + (if (or (< attempt tex-chars-threshold) (not (exotic-char? random))) + (let ([i (random (- #x7E #x20 1))] + [_ (- (char->integer #\_) #x20)]) + (integer->char (+ #x20 (if (= i _) (add1 i) i)))) + (if (or (< attempt chinese-chars-threshold) (not (exotic-char? random))) + (car (string->list (pick-from-list (map cadr tex-shortcut-table) random))) + (integer->char (+ #x4E00 (random (- #x9FCF #x4E00)))))))) (define (random-string lang-chars lang-lits length attempt [random random]) - (if (use-lang-literal? random) + (if (and (not (null? lang-lits)) (use-lang-literal? random)) (pick-from-list lang-lits random) (list->string (build-list length (λ (_) (pick-char attempt lang-chars random)))))) @@ -135,96 +132,110 @@ 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 nt bound-vars size) + (define (generate-nt nt bound-vars size holes) (let loop ([nts (compiled-lang-lang lang)]) (cond [(null? nts) (error 'generate-nt "didn't find non-terminal ~s" nt)] [(eq? (nt-name (car nts)) nt) (let* ([prods (if (zero? size) (min-prods (car nts) base-table) (nt-rhs (car nts)))] - [rhs ((next-non-terminal-decision) prods bound-vars size)]) - (generate-pat (rhs-pattern rhs) bound-vars (rhs-var-info rhs) (max 0 (sub1 size))))] + [rhs ((next-non-terminal-decision) prods bound-vars size)] + [size (max 0 (sub1 size))]) + (generate-pat (rhs-pattern rhs) bound-vars (rhs-var-info rhs) size holes))] [else (loop (cdr nts))]))) (define-struct found-vars (nt source bound-vars found-nt?)) - (define (generate-pat pat bound-vars var-info size) + (define (generate-pat pat bound-vars var-info size holes) (let* ([found-vars-table (map (λ (binds) (make-found-vars (binds-binds binds) (binds-source binds) '() #f)) var-info)] - [found-nt? #f] [bindings (make-immutable-hasheq null)] [mismatches (make-immutable-hasheq null)]) - (let loop ([pat pat]) + (let loop ([pat pat] [holes holes]) + (define (generate/retry #:gen [gen (λ (p) (loop p holes))] success? . subpatterns) + (let ([old-fvt found-vars-table] + [old-bindings bindings] + [old-mismatches mismatches]) + (let retry ([remaining generation-retries]) + (if (zero? remaining) + (generation-failure pat) + (let ([generated (map gen subpatterns)]) + (if (apply success? generated) + (if (= 1 (length generated)) + (car generated) + generated) + (begin + (set! found-vars-table old-fvt) + (set! bindings old-bindings) + (set! mismatches old-mismatches) + (retry (sub1 remaining))))))))) + + (define (generate-hole name) + (let* ([not-in-hole (gensym)] + [generate-contractum (hash-ref holes name not-in-hole)]) + (if (eq? generate-contractum not-in-hole) + (if name (make-hole/intern name) (term hole)) + (generate-contractum)))) (match pat [`number ((next-number-decision) random-numbers)] [`(variable-except ,vars ...) - (let try () (let ([var (loop 'variable)]) (if (memq var vars) (try) var)))] + (generate/retry (λ (var) (not (memq var vars))) 'variable)] [`variable ((next-variable-decision) lang-chars lang-lits bound-vars attempt)] [`(variable-prefix ,prefix) - (string->symbol (string-append (symbol->string prefix) (symbol->string (loop 'variable))))] + (string->symbol (string-append (symbol->string prefix) + (symbol->string (loop 'variable holes))))] [`string ((next-string-decision) lang-chars lang-lits attempt)] [`(side-condition ,pattern ,(? procedure? condition)) - (let ([old-fvt found-vars-table] - [old-bindings bindings] - [old-mismatches mismatches]) - (let retry ([remaining generation-retries]) - (if (zero? remaining) - (generation-failure pat) - (let ([term (loop pattern)]) - (if (condition (make-bindings (hash-map bindings (λ (name exp) (make-bind name exp))))) - term - (begin - (set! found-vars-table old-fvt) - (set! bindings old-bindings) - (set! mismatches old-mismatches) - (retry (sub1 remaining))))))))] + (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 ,id ,p) + [`(name ,(? symbol? id) ,p) (define (generate/record) - (let ([term (loop p)]) + (let ([term (loop p holes)]) (set! bindings (hash-set bindings id term)) term)) (hash-ref bindings id generate/record)] + [`hole (generate-hole #f)] + [`(in-hole ,context ,contractum) + (loop context (hash-set holes #f (λ () (loop contractum holes))))] + [`(hole ,(? symbol? name)) (generate-hole name)] + [`(in-named-hole ,name ,context ,contractum) + (loop context (hash-set holes name (λ () (loop contractum holes))))] [(and (? symbol?) (? (λ (x) (or (is-nt? lang x) (underscored-built-in? x))))) - (define (update/generate undecorated decorated) - (let* ([new-bound-vars (append (extract-bound-vars decorated found-vars-table) bound-vars)] - [term (if (underscored-built-in? pat) - (loop undecorated) - (generate-nt undecorated new-bound-vars size))]) - (values term (extend-found-vars decorated term found-vars-table)))) + (define ((generate-nt/underscored decorated) undecorated) + (let* ([vars (append (extract-bound-vars decorated found-vars-table) bound-vars)] + [term (if (is-nt? lang undecorated) + (generate-nt undecorated vars size holes) + (generate-pat undecorated vars null size holes))]) + (begin + (set! found-vars-table (extend-found-vars decorated term found-vars-table)) + term))) (match (symbol->string pat) [(regexp #rx"^([^_]*)_[^_]*$" (list _ undecorated)) - (hash-ref + (hash-ref bindings pat - (λ () - (let-values ([(term fvt) (update/generate (string->symbol undecorated) pat)]) - (set! found-vars-table fvt) + (λ () + (let ([term ((generate-nt/underscored pat) (string->symbol undecorated))]) (set! bindings (hash-set bindings pat term)) term)))] - [(regexp #rx"([^_]*)_!_[^_]*$" (list _ undecorated)) - (let loop ([remaining generation-retries]) - (if (zero? remaining) - (generation-failure pat) - (let-values ([(term fvt) (update/generate (string->symbol undecorated) pat)]) - (let ([others (hash-ref mismatches pat (λ () null))]) - (if (member term others) - (loop (sub1 remaining)) - (begin - (set! found-vars-table fvt) - (set! mismatches - (hash-set mismatches pat (cons term others))) - term))))))] - [else - (let-values ([(term fvt) (update/generate pat pat)]) - (begin (set! found-vars-table fvt) term))])] + [(regexp #rx"([^_]*)_!_[^_]*$" (list _ undecorated)) + (let* ([prior (hash-ref mismatches pat null)] + [term (generate/retry + (λ (t) (not (member t prior))) + (string->symbol undecorated) + #:gen (generate-nt/underscored pat))]) + (set! mismatches (hash-set mismatches pat (cons term prior))) + term)] + [else ((generate-nt/underscored pat) pat)])] [(or (? symbol?) (? number?) (? string?) (? boolean?)) pat] [(? null? pat) '()] [(? pair? pat) (if (or (null? (cdr pat)) (not (eq? '... (cadr pat)))) - (cons (loop (car pat)) - (loop (cdr pat))) - (append (build-list ((next-sequence-decision)) (λ (i) (loop (car pat)))) - (loop (cddr pat))))] + (cons (loop (car pat) holes) + (loop (cdr pat) holes)) + (append (build-list ((next-sequence-decision)) (λ (i) (loop (car pat) holes))) + (loop (cddr pat) holes)))] [else (error 'generate "unknown pattern ~s\n" pat)])))) @@ -260,7 +271,7 @@ To do a better job of not generating programs with free variables, [else found-vars])) found-vars-table)) - (generate-pat nt '() '() size)) + (generate-pat nt '() '() size (make-immutable-hash null))) ;; find-base-cases : compiled-language -> hash-table (define (find-base-cases lang) @@ -340,7 +351,8 @@ To do a better job of not generating programs with free variables, ;; underscored-built-in? : symbol -> boolean (define (underscored-built-in? sym) - (not (false? (memq (symbol->nt sym) underscore-allowed)))) + (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]) diff --git a/collects/redex/private/run-tests.ss b/collects/redex/private/run-tests.ss index 84190b638d..17b0d926b8 100644 --- a/collects/redex/private/run-tests.ss +++ b/collects/redex/private/run-tests.ss @@ -11,7 +11,6 @@ "term-test.ss" "tl-test.ss" "matcher-test.ss" - "schemeunit-test.ss" "lw-test.ss") (printf "\nWARNING: didn't run color-test.ss or subst-test.ss\n"))