diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index f2e4890d92..e01772bcad 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -145,6 +145,7 @@ #:nt [nt pick-nt] #:str [str pick-string] #:num [num pick-from-list] + #:any [any pick-any] #:seq [seq pick-length]) (define-syntax decision (syntax-rules () @@ -154,6 +155,7 @@ (define next-non-terminal-decision (decision nt)) (define next-number-decision (decision num)) (define next-string-decision (decision str)) + (define next-any-decision (decision any)) (define next-sequence-decision (decision seq)))) (let () @@ -418,6 +420,41 @@ (test (let/ec k (generate lang 'd 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))))) '(x))) +(let () + (define-language lc + (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)))) + 'x)) + +(let () + (define-language four + (e 4) + (f 5)) + + ;; `any' pattern + (test (call-with-values (λ () (pick-any four (make-random (list 0 1)))) list) + (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 + (decisions #:any (list (λ _ (values sexp 'sexp))) + #:nt (list (select-pattern '(sexp ...)) + (select-pattern 'string) + (select-pattern 'string) + (select-pattern 'string)) + #:seq (list (λ _ 3)) + #:str (list (λ _ "foo") (λ _ "bar") (λ _ "baz")))) + '("foo" "bar" "baz"))) + +;; `hide-hole' pattern +(let () + (define-language lang + (e (hide-hole (in-hole ((hide-hole hole) hole) 1)))) + (test (generate lang 'e 5 0) (term ((hole #f) 1)))) + (define (output-error-port thunk) (let ([port (open-output-string)]) (parameterize ([current-error-port port]) diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index 8885b8a2de..7d0afcced6 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -103,6 +103,11 @@ To do a better job of not generating programs with free variables, (pick-from-list lang-lits random) (list->string (build-list length (λ (_) (pick-char attempt lang-chars random)))))) +(define (pick-any lang [random random]) + (if (zero? (random 5)) + (values lang (pick-from-list (map nt-name (compiled-lang-lang lang)) random)) + (values sexp (nt-name (car (compiled-lang-lang sexp)))))) + (define (pick-string lang-chars lang-lits attempt [random random]) (random-string lang-chars lang-lits (pick-length random) attempt random)) @@ -124,6 +129,9 @@ To do a better job of not generating programs with free variables, (error 'generate "unable to generate pattern ~s in ~s attempts" pat generation-retries)) +;; 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-values/invoke-unit decisions@ (import) (export decisions^)) @@ -179,6 +187,8 @@ To do a better job of not generating programs with free variables, [`(variable-except ,vars ...) (generate/retry (λ (var) (not (memq var vars))) 'variable)] [`variable ((next-variable-decision) lang-chars lang-lits bound-vars attempt)] + [`variable-not-otherwise-mentioned + (generate/retry (λ (var) (not (memq var (compiled-lang-literals lang)))) 'variable)] [`(variable-prefix ,prefix) (string->symbol (string-append (symbol->string prefix) (symbol->string (loop 'variable holes))))] @@ -201,6 +211,10 @@ To do a better job of not generating programs with free variables, [`(hole ,(? symbol? name)) (generate-hole name)] [`(in-named-hole ,name ,context ,contractum) (loop context (hash-set holes name (λ () (loop contractum holes))))] + [`(hide-hole ,pattern) (loop pattern (make-immutable-hasheq null))] + [`any + (let-values ([(lang nt) ((next-any-decision) lang)]) + (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)] @@ -271,7 +285,7 @@ To do a better job of not generating programs with free variables, [else found-vars])) found-vars-table)) - (generate-pat nt '() '() size (make-immutable-hash null))) + (generate-pat nt '() '() size (make-immutable-hasheq null))) ;; find-base-cases : compiled-language -> hash-table (define (find-base-cases lang) @@ -359,10 +373,11 @@ To do a better job of not generating programs with free variables, (if (zero? i) (fprintf (current-error-port) "No failures in ~a attempts\n" attempts) (let ([t (generate lang nt size (- attempts i))]) - (if (pred? t) + (if (with-handlers ([exn:fail? (λ (exn) (error 'try "checking ~s: ~s" t exn))]) + (pred? t)) (loop (- i 1)) (begin - (fprintf (current-error-port) "FAILED!\n") + (fprintf (current-error-port) "FAILED after ~s attempt(s)!\n" (add1 (- attempts i))) (pretty-print t (current-error-port)))))))) (define-syntax check @@ -379,6 +394,7 @@ To do a better job of not generating programs with free variables, next-number-decision next-non-terminal-decision next-sequence-decision + next-any-decision next-string-decision)) (define random-decisions@ @@ -387,6 +403,7 @@ To do a better job of not generating programs with free variables, (define (next-number-decision) pick-from-list) (define (next-non-terminal-decision) pick-nt) (define (next-sequence-decision) pick-length) + (define (next-any-decision) pick-any) (define (next-string-decision) pick-string))) (define (sexp? x) @@ -394,7 +411,7 @@ 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) + check pick-nt unique-chars pick-any sexp) (provide/contract [generate any/c]