suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added support for patterns any', hide-hole', and

Browse Source 
`variable-not-otherwise-mentioned' and improved error reporting for
`try'.

svn: r11035
This commit is contained in:
Casey Klein 2008-08-02 15:35:54 +00:00
parent 50f1e13652
commit 3e3bbe5c24
2 changed files with 58 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/redex/private/rg-test.ss
View File

@ -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])

25
collects/redex/private/rg.ss
View File

@ -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]