Dropped the "preferred productions" heuristic and the failed prototype
supporting accumulator-style generators. svn: r17851
This commit is contained in:
Casey Klein
parent
980d48ce19
commit
4271b7970c
|
|
@ -14,9 +14,6 @@
|
|||
|
||||
(define (exotic-choice? [random random]) (= 0 (random 5)))
|
||||
(define (use-lang-literal? [random random]) (= 0 (random 20)))
|
||||
(define (preferred-production? attempt [random random])
|
||||
(and (>= attempt preferred-production-threshold)
|
||||
(zero? (random 2))))
|
||||
|
||||
(define default-check-attempts 1000)
|
||||
|
||||
|
|
@ -57,27 +54,8 @@
|
|||
(define (pick-string lang-lits attempt [random random])
|
||||
(random-string lang-lits (random-natural 1/5 random) attempt random))
|
||||
|
||||
(define (pick-nt name cross? lang attempt pref-prods
|
||||
[random random]
|
||||
[pref-prod? preferred-production?])
|
||||
(let ([prods (nt-rhs (nt-by-name lang name cross?))])
|
||||
(cond [(and pref-prods (pref-prod? attempt random))
|
||||
(hash-ref
|
||||
((if cross? pref-prods-cross pref-prods-non-cross)
|
||||
pref-prods)
|
||||
name)]
|
||||
[else prods])))
|
||||
|
||||
(define-struct pref-prods (cross non-cross))
|
||||
|
||||
(define (pick-preferred-productions lang)
|
||||
(let ([pick (λ (sel)
|
||||
(for/hash ([nt (sel lang)])
|
||||
(values (nt-name nt)
|
||||
(list (pick-from-list (nt-rhs nt))))))])
|
||||
(make-pref-prods
|
||||
(pick compiled-lang-cclang)
|
||||
(pick compiled-lang-lang))))
|
||||
(define (pick-nts name cross? lang attempt)
|
||||
(nt-rhs (nt-by-name lang name cross?)))
|
||||
|
||||
(define (pick-from-list l [random random]) (list-ref l (random (length l))))
|
||||
|
||||
|
|
@ -118,9 +96,6 @@
|
|||
(define proportion-at-size 1/10)
|
||||
(define post-threshold-incr 50)
|
||||
|
||||
(define preferred-production-threshold
|
||||
(+ retry-threshold 2000))
|
||||
|
||||
;; Determines the parameter p for which random-natural's expected value is E
|
||||
(define (expected-value->p E)
|
||||
;; E = 0 => p = 1, which breaks random-natural
|
||||
|
|
@ -177,11 +152,11 @@
|
|||
who what attempts (if (= attempts 1) "" "s"))])
|
||||
(raise (make-exn:fail:redex:generation-failure str (current-continuation-marks)))))
|
||||
|
||||
(define (generate lang decisions@ user-gen retries what)
|
||||
(define (generate lang decisions@ retries what)
|
||||
(define-values/invoke-unit decisions@
|
||||
(import) (export decisions^))
|
||||
|
||||
(define ((generate-nt lang base-cases generate pref-prods)
|
||||
(define ((generate-nt lang base-cases generate)
|
||||
name cross? size attempt in-hole env)
|
||||
(let*-values
|
||||
([(term _)
|
||||
|
|
@ -193,7 +168,7 @@
|
|||
(min-prods (nt-by-name lang name cross?)
|
||||
((if cross? base-cases-cross base-cases-non-cross)
|
||||
base-cases))
|
||||
((next-non-terminal-decision) name cross? lang attempt pref-prods)))])
|
||||
((next-non-terminal-decision) name cross? lang attempt)))])
|
||||
(generate (max 0 (sub1 size)) attempt empty-env in-hole (rhs-pattern rhs))))
|
||||
(λ (_ env) (mismatches-satisfied? env))
|
||||
size attempt)])
|
||||
|
|
@ -279,114 +254,101 @@
|
|||
(cons (make-bind (binder-name key) val) bindings)
|
||||
bindings))))
|
||||
|
||||
(define (generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat)
|
||||
(define recur (curry generate-pat lang sexp pref-prods user-gen user-acc size attempt))
|
||||
(define (generate-pat lang sexp size attempt env in-hole pat)
|
||||
(define recur (curry generate-pat lang sexp size attempt))
|
||||
(define recur/pat (recur env in-hole))
|
||||
(define ((recur/pat/size-attempt pat) size attempt)
|
||||
(generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat))
|
||||
(generate-pat lang sexp size attempt env in-hole pat))
|
||||
|
||||
(define clang (rg-lang-clang lang))
|
||||
(define gen-nt
|
||||
(generate-nt
|
||||
clang
|
||||
(rg-lang-base-cases lang)
|
||||
(curry generate-pat lang sexp pref-prods user-gen user-acc)
|
||||
pref-prods))
|
||||
(curry generate-pat lang sexp)))
|
||||
|
||||
(define (default-gen user-acc)
|
||||
(match pat
|
||||
[`number (values ((next-number-decision) attempt) env)]
|
||||
[`natural (values ((next-natural-decision) attempt) env)]
|
||||
[`integer (values ((next-integer-decision) attempt) env)]
|
||||
[`real (values ((next-real-decision) attempt) env)]
|
||||
[`(variable-except ,vars ...)
|
||||
(generate/pred 'variable
|
||||
(recur/pat/size-attempt 'variable)
|
||||
(λ (var _) (not (memq var vars)))
|
||||
size attempt)]
|
||||
[`variable
|
||||
(values ((next-variable-decision) (rg-lang-lits lang) attempt)
|
||||
env)]
|
||||
[`variable-not-otherwise-mentioned
|
||||
(generate/pred 'variable
|
||||
(recur/pat/size-attempt 'variable)
|
||||
(λ (var _) (not (memq var (compiled-lang-literals clang))))
|
||||
size attempt)]
|
||||
[`(variable-prefix ,prefix)
|
||||
(define (symbol-append prefix suffix)
|
||||
(string->symbol (string-append (symbol->string prefix) (symbol->string suffix))))
|
||||
(let-values ([(term env) (recur/pat 'variable)])
|
||||
(values (symbol-append prefix term) env))]
|
||||
[`string
|
||||
(values ((next-string-decision) (rg-lang-lits lang) attempt)
|
||||
env)]
|
||||
[`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc)
|
||||
(generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc)
|
||||
(recur/pat/size-attempt pat)
|
||||
(λ (_ env) (condition (bindings env)))
|
||||
size attempt)]
|
||||
[`(name ,(? symbol? id) ,p)
|
||||
(let-values ([(term env) (recur/pat p)])
|
||||
(values term (hash-set env (make-binder id) term)))]
|
||||
[`hole (values in-hole env)]
|
||||
[`(in-hole ,context ,contractum)
|
||||
(let-values ([(term env) (recur/pat contractum)])
|
||||
(recur env term context))]
|
||||
[`(hide-hole ,pattern) (recur env the-hole pattern)]
|
||||
[`any
|
||||
(let*-values ([(new-lang nt) ((next-any-decision) lang sexp)]
|
||||
; Don't use preferred productions for the sexp language.
|
||||
[(pref-prods) (if (eq? new-lang lang) pref-prods #f)]
|
||||
[(term _) (generate-pat new-lang
|
||||
sexp
|
||||
pref-prods
|
||||
user-gen
|
||||
user-acc
|
||||
size
|
||||
attempt
|
||||
empty-env
|
||||
the-hole
|
||||
nt)])
|
||||
(values term env))]
|
||||
[(? (is-nt? clang))
|
||||
(values (gen-nt pat #f size attempt in-hole env) env)]
|
||||
[(struct binder ((or (? (is-nt? clang) nt)
|
||||
(app (symbol-match named-nt-rx) (? (is-nt? clang) nt)))))
|
||||
(generate/prior pat env (λ () (recur/pat nt)))]
|
||||
[(struct binder ((or (? built-in? b)
|
||||
(app (symbol-match named-nt-rx) (? built-in? b)))))
|
||||
(generate/prior pat env (λ () (recur/pat b)))]
|
||||
[(struct mismatch (name (app (symbol-match mismatch-nt-rx)
|
||||
(? symbol? (? (is-nt? clang) nt)))))
|
||||
(let-values ([(term _) (recur/pat nt)])
|
||||
(values term (hash-set env pat term)))]
|
||||
[(struct mismatch (name (app (symbol-match mismatch-nt-rx)
|
||||
(? symbol? (? built-in? b)))))
|
||||
(let-values ([(term _) (recur/pat b)])
|
||||
(values term (hash-set env pat term)))]
|
||||
[`(cross ,(? symbol? cross-nt))
|
||||
(values (gen-nt cross-nt #t size attempt in-hole env) env)]
|
||||
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat env)]
|
||||
[(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
|
||||
(let*-values ([(length) (let ([prior (hash-ref env class #f)])
|
||||
(if prior prior ((next-sequence-decision) attempt)))]
|
||||
[(seq env) (generate-sequence ellipsis recur env length)]
|
||||
[(rest env) (recur (hash-set (hash-set env class length) name length)
|
||||
in-hole rest)])
|
||||
(values (append seq rest) env))]
|
||||
[(list-rest pat rest)
|
||||
(let*-values
|
||||
([(pat-term env) (recur/pat pat)]
|
||||
[(rest-term env) (recur env in-hole rest)])
|
||||
(values (cons pat-term rest-term) env))]
|
||||
[else
|
||||
(error what "unknown pattern ~s\n" pat)]))
|
||||
|
||||
(user-gen
|
||||
pat size in-hole user-acc env attempt
|
||||
(λ (pat #:size [size size] #:contractum [in-hole in-hole] #:acc [user-acc user-acc] #:env [env env])
|
||||
(generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat))
|
||||
default-gen))
|
||||
(match pat
|
||||
[`number (values ((next-number-decision) attempt) env)]
|
||||
[`natural (values ((next-natural-decision) attempt) env)]
|
||||
[`integer (values ((next-integer-decision) attempt) env)]
|
||||
[`real (values ((next-real-decision) attempt) env)]
|
||||
[`(variable-except ,vars ...)
|
||||
(generate/pred 'variable
|
||||
(recur/pat/size-attempt 'variable)
|
||||
(λ (var _) (not (memq var vars)))
|
||||
size attempt)]
|
||||
[`variable
|
||||
(values ((next-variable-decision) (rg-lang-lits lang) attempt)
|
||||
env)]
|
||||
[`variable-not-otherwise-mentioned
|
||||
(generate/pred 'variable
|
||||
(recur/pat/size-attempt 'variable)
|
||||
(λ (var _) (not (memq var (compiled-lang-literals clang))))
|
||||
size attempt)]
|
||||
[`(variable-prefix ,prefix)
|
||||
(define (symbol-append prefix suffix)
|
||||
(string->symbol (string-append (symbol->string prefix) (symbol->string suffix))))
|
||||
(let-values ([(term env) (recur/pat 'variable)])
|
||||
(values (symbol-append prefix term) env))]
|
||||
[`string
|
||||
(values ((next-string-decision) (rg-lang-lits lang) attempt)
|
||||
env)]
|
||||
[`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc)
|
||||
(generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc)
|
||||
(recur/pat/size-attempt pat)
|
||||
(λ (_ env) (condition (bindings env)))
|
||||
size attempt)]
|
||||
[`(name ,(? symbol? id) ,p)
|
||||
(let-values ([(term env) (recur/pat p)])
|
||||
(values term (hash-set env (make-binder id) term)))]
|
||||
[`hole (values in-hole env)]
|
||||
[`(in-hole ,context ,contractum)
|
||||
(let-values ([(term env) (recur/pat contractum)])
|
||||
(recur env term context))]
|
||||
[`(hide-hole ,pattern) (recur env the-hole pattern)]
|
||||
[`any
|
||||
(let*-values ([(new-lang nt) ((next-any-decision) lang sexp)]
|
||||
[(term _) (generate-pat new-lang
|
||||
sexp
|
||||
size
|
||||
attempt
|
||||
empty-env
|
||||
the-hole
|
||||
nt)])
|
||||
(values term env))]
|
||||
[(? (is-nt? clang))
|
||||
(values (gen-nt pat #f size attempt in-hole env) env)]
|
||||
[(struct binder ((or (? (is-nt? clang) nt)
|
||||
(app (symbol-match named-nt-rx) (? (is-nt? clang) nt)))))
|
||||
(generate/prior pat env (λ () (recur/pat nt)))]
|
||||
[(struct binder ((or (? built-in? b)
|
||||
(app (symbol-match named-nt-rx) (? built-in? b)))))
|
||||
(generate/prior pat env (λ () (recur/pat b)))]
|
||||
[(struct mismatch (name (app (symbol-match mismatch-nt-rx)
|
||||
(? symbol? (? (is-nt? clang) nt)))))
|
||||
(let-values ([(term _) (recur/pat nt)])
|
||||
(values term (hash-set env pat term)))]
|
||||
[(struct mismatch (name (app (symbol-match mismatch-nt-rx)
|
||||
(? symbol? (? built-in? b)))))
|
||||
(let-values ([(term _) (recur/pat b)])
|
||||
(values term (hash-set env pat term)))]
|
||||
[`(cross ,(? symbol? cross-nt))
|
||||
(values (gen-nt cross-nt #t size attempt in-hole env) env)]
|
||||
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat env)]
|
||||
[(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
|
||||
(let*-values ([(length) (let ([prior (hash-ref env class #f)])
|
||||
(if prior prior ((next-sequence-decision) attempt)))]
|
||||
[(seq env) (generate-sequence ellipsis recur env length)]
|
||||
[(rest env) (recur (hash-set (hash-set env class length) name length)
|
||||
in-hole rest)])
|
||||
(values (append seq rest) env))]
|
||||
[(list-rest pat rest)
|
||||
(let*-values
|
||||
([(pat-term env) (recur/pat pat)]
|
||||
[(rest-term env) (recur env in-hole rest)])
|
||||
(values (cons pat-term rest-term) env))]
|
||||
[else
|
||||
(error what "unknown pattern ~s\n" pat)]))
|
||||
|
||||
(let ([rg-lang (prepare-lang lang)]
|
||||
[rg-sexp (prepare-lang sexp)])
|
||||
|
|
@ -400,9 +362,6 @@
|
|||
(generate-pat
|
||||
rg-lang
|
||||
rg-sexp
|
||||
((next-pref-prods-decision) (rg-lang-clang rg-lang))
|
||||
user-gen
|
||||
#f
|
||||
size
|
||||
attempt
|
||||
empty-env
|
||||
|
|
@ -684,26 +643,24 @@
|
|||
(define (defer-all pat size in-hole acc env att recur defer)
|
||||
(defer acc))
|
||||
|
||||
(define-for-syntax (term-generator lang pat decisions@ custom retries what)
|
||||
(define-for-syntax (term-generator lang pat decisions@ retries what)
|
||||
(with-syntax ([pattern
|
||||
(rewrite-side-conditions/check-errs
|
||||
(language-id-nts lang what)
|
||||
what #t pat)])
|
||||
#`((generate #,lang #,decisions@ #,custom #,retries '#,what) `pattern)))
|
||||
#`((generate #,lang #,decisions@ #,retries '#,what) `pattern)))
|
||||
|
||||
(define-syntax (generate-term stx)
|
||||
(syntax-case stx ()
|
||||
[(_ lang pat size . kw-args)
|
||||
(with-syntax ([(attempt retries custom)
|
||||
(with-syntax ([(attempt retries)
|
||||
(parse-kw-args `((#:attempt . 1)
|
||||
(#:retries . ,#'default-retries)
|
||||
(#:custom . ,#'defer-all))
|
||||
(#:retries . ,#'default-retries))
|
||||
(syntax kw-args)
|
||||
stx)])
|
||||
(with-syntax ([generate (term-generator #'lang
|
||||
#'pat
|
||||
#'(generation-decisions)
|
||||
#'custom
|
||||
#'retries
|
||||
'generate-term)])
|
||||
(syntax/loc stx
|
||||
|
|
@ -734,12 +691,11 @@
|
|||
(let-values ([(names names/ellipses)
|
||||
(extract-names (language-id-nts #'lang 'redex-check)
|
||||
'redex-check #t #'pat)]
|
||||
[(attempts-stx source-stx retries-stx custom-stx)
|
||||
[(attempts-stx source-stx retries-stx)
|
||||
(apply values
|
||||
(parse-kw-args `((#:attempts . ,#'default-check-attempts)
|
||||
(#:source . #f)
|
||||
(#:retries . ,#'default-retries)
|
||||
(#:custom . ,#'defer-all))
|
||||
(#:retries . ,#'default-retries))
|
||||
(syntax kw-args)
|
||||
stx))])
|
||||
(with-syntax ([(name ...) names]
|
||||
|
|
@ -751,18 +707,7 @@
|
|||
property)))])
|
||||
(quasisyntax/loc stx
|
||||
(let ([att (assert-nat 'redex-check #,attempts-stx)]
|
||||
[ret (assert-nat 'redex-check #,retries-stx)]
|
||||
[custom (contract
|
||||
(-> any/c natural-number/c any/c any/c hash? natural-number/c
|
||||
(->* (any/c)
|
||||
(#:size natural-number/c
|
||||
#:contractum any/c
|
||||
#:acc any/c
|
||||
#:env hash?)
|
||||
(values any/c hash?))
|
||||
(-> any/c (values any/c hash?))
|
||||
(values any/c hash?))
|
||||
#,custom-stx '+ '-)])
|
||||
[ret (assert-nat 'redex-check #,retries-stx)])
|
||||
(unsyntax
|
||||
(if source-stx
|
||||
#`(let-values ([(metafunc/red-rel num-cases)
|
||||
|
|
@ -776,7 +721,6 @@
|
|||
metafunc/red-rel
|
||||
property
|
||||
random-decisions@
|
||||
custom
|
||||
(max 1 (floor (/ att num-cases)))
|
||||
ret
|
||||
'redex-check
|
||||
|
|
@ -784,7 +728,7 @@
|
|||
(test-match lang pat)
|
||||
(λ (generated) (redex-error 'redex-check "~s does not match ~s" generated 'pat))))
|
||||
#`(check-prop
|
||||
#,(term-generator #'lang #'pat #'random-decisions@ #'custom #'ret 'redex-check)
|
||||
#,(term-generator #'lang #'pat #'random-decisions@ #'ret 'redex-check)
|
||||
property att show)))
|
||||
(void))))))]))
|
||||
|
||||
|
|
@ -831,10 +775,9 @@
|
|||
[(_ name . kw-args)
|
||||
(identifier? #'name)
|
||||
(with-syntax ([m (metafunc/err #'name stx)]
|
||||
[(attempts retries custom)
|
||||
[(attempts retries)
|
||||
(parse-kw-args `((#:attempts . ,#'default-check-attempts)
|
||||
(#:retries . ,#'default-retries)
|
||||
(#:custom . ,#'defer-all))
|
||||
(#:retries . ,#'default-retries))
|
||||
(syntax kw-args)
|
||||
stx)]
|
||||
[show (show-message stx)])
|
||||
|
|
@ -844,7 +787,7 @@
|
|||
[decisions@ (generation-decisions)]
|
||||
[att (assert-nat 'check-metafunction-contract attempts)])
|
||||
(check-prop
|
||||
((generate lang decisions@ custom retries 'check-metafunction-contract)
|
||||
((generate lang decisions@ retries 'check-metafunction-contract)
|
||||
(if dom dom '(any (... ...))))
|
||||
(λ (t _)
|
||||
(with-handlers ([exn:fail:redex? (λ (_) #f)])
|
||||
|
|
@ -852,10 +795,10 @@
|
|||
att
|
||||
show))))]))
|
||||
|
||||
(define (check-lhs-pats lang mf/rr prop decisions@ custom attempts retries what show
|
||||
(define (check-lhs-pats lang mf/rr prop decisions@ attempts retries what show
|
||||
[match #f]
|
||||
[match-fail #f])
|
||||
(let ([lang-gen (generate lang decisions@ custom retries what)])
|
||||
(let ([lang-gen (generate lang decisions@ retries what)])
|
||||
(let-values ([(pats srcs)
|
||||
(cond [(metafunc-proc? mf/rr)
|
||||
(values (map metafunc-case-lhs-pat (metafunc-proc-cases mf/rr))
|
||||
|
|
@ -884,10 +827,9 @@
|
|||
(syntax-case stx ()
|
||||
[(_ name property . kw-args)
|
||||
(with-syntax ([m (metafunc/err #'name stx)]
|
||||
[(attempts retries custom)
|
||||
[(attempts retries)
|
||||
(parse-kw-args `((#:attempts . , #'default-check-attempts)
|
||||
(#:retries . ,#'default-retries)
|
||||
(#:custm . ,#'defer-all))
|
||||
(#:retries . ,#'default-retries))
|
||||
(syntax kw-args)
|
||||
stx)]
|
||||
[show (show-message stx)])
|
||||
|
|
@ -899,7 +841,6 @@
|
|||
m
|
||||
(λ (term _) (property term))
|
||||
(generation-decisions)
|
||||
custom
|
||||
att
|
||||
ret
|
||||
'check-metafunction
|
||||
|
|
@ -917,11 +858,10 @@
|
|||
(define-syntax (check-reduction-relation stx)
|
||||
(syntax-case stx ()
|
||||
[(_ relation property . kw-args)
|
||||
(with-syntax ([(attempts retries decisions@ custom)
|
||||
(with-syntax ([(attempts retries decisions@)
|
||||
(parse-kw-args `((#:attempts . , #'default-check-attempts)
|
||||
(#:retries . ,#'default-retries)
|
||||
(#:decisions . ,#'random-decisions@)
|
||||
(#:custom . ,#'defer-all))
|
||||
(#:decisions . ,#'random-decisions@))
|
||||
(syntax kw-args)
|
||||
stx)]
|
||||
[show (show-message stx)])
|
||||
|
|
@ -934,7 +874,6 @@
|
|||
rel
|
||||
(λ (term _) (property term))
|
||||
decisions@
|
||||
custom
|
||||
attempts
|
||||
retries
|
||||
'check-reduction-relation
|
||||
|
|
@ -949,8 +888,7 @@
|
|||
next-non-terminal-decision
|
||||
next-sequence-decision
|
||||
next-any-decision
|
||||
next-string-decision
|
||||
next-pref-prods-decision))
|
||||
next-string-decision))
|
||||
|
||||
(define random-decisions@
|
||||
(unit (import) (export decisions^)
|
||||
|
|
@ -959,11 +897,10 @@
|
|||
(define (next-natural-decision) pick-natural)
|
||||
(define (next-integer-decision) pick-integer)
|
||||
(define (next-real-decision) pick-real)
|
||||
(define (next-non-terminal-decision) pick-nt)
|
||||
(define (next-non-terminal-decision) pick-nts)
|
||||
(define (next-sequence-decision) pick-sequence-length)
|
||||
(define (next-any-decision) pick-any)
|
||||
(define (next-string-decision) pick-string)
|
||||
(define (next-pref-prods-decision) pick-preferred-productions)))
|
||||
(define (next-string-decision) pick-string)))
|
||||
|
||||
(define generation-decisions (make-parameter random-decisions@))
|
||||
|
||||
|
|
@ -978,19 +915,16 @@
|
|||
(struct-out mismatch)
|
||||
(struct-out class)
|
||||
(struct-out binder)
|
||||
(struct-out base-cases)
|
||||
(struct-out pref-prods))
|
||||
(struct-out base-cases))
|
||||
|
||||
(provide pick-from-list pick-sequence-length
|
||||
pick-char pick-var pick-string
|
||||
pick-nt pick-any pick-preferred-productions
|
||||
(provide pick-from-list pick-sequence-length pick-nts
|
||||
pick-char pick-var pick-string pick-any
|
||||
pick-number pick-natural pick-integer pick-real
|
||||
parse-pattern unparse-pattern
|
||||
parse-language prepare-lang
|
||||
class-reassignments reassign-classes
|
||||
default-retries proportion-at-size
|
||||
preferred-production-threshold retry-threshold
|
||||
proportion-before-threshold post-threshold-incr
|
||||
retry-threshold proportion-before-threshold post-threshold-incr
|
||||
is-nt? nt-by-name min-prods
|
||||
generation-decisions decisions^
|
||||
random-string
|
||||
|
|
|
|||
|
|
@ -111,23 +111,6 @@
|
|||
(test (pick-string lits 0 (make-random .5 1 0 1 1 1 2 1)) "abc")
|
||||
(test (pick-var lits 0 (make-random .01 1 0 1 1 1 2 1)) 'abc))
|
||||
|
||||
(let ()
|
||||
(define-language L
|
||||
(a 5 (x a))
|
||||
(b 4))
|
||||
(test (pick-nt 'a #f L 1 'dontcare)
|
||||
(nt-rhs (car (compiled-lang-lang L))))
|
||||
(test (pick-nt 'a #f L preferred-production-threshold 'dontcare (make-random 1))
|
||||
(nt-rhs (car (compiled-lang-lang L))))
|
||||
(let ([pref (car (nt-rhs (car (compiled-lang-lang L))))])
|
||||
(test (pick-nt 'a #f L preferred-production-threshold
|
||||
(make-pref-prods 'dont-care
|
||||
(make-immutable-hash `((a ,pref))))
|
||||
(make-random 0))
|
||||
(list pref)))
|
||||
(test (pick-nt 'b #f L preferred-production-threshold #f)
|
||||
(nt-rhs (cadr (compiled-lang-lang L)))))
|
||||
|
||||
(define-syntax raised-exn-msg
|
||||
(syntax-rules ()
|
||||
[(_ expr) (raised-exn-msg exn:fail? expr)]
|
||||
|
|
@ -141,7 +124,7 @@
|
|||
|
||||
(define (patterns . selectors)
|
||||
(map (λ (selector)
|
||||
(λ (name cross? lang size pref-prods)
|
||||
(λ (name cross? lang sizes)
|
||||
(list (selector (nt-rhs (nt-by-name lang name cross?))))))
|
||||
selectors))
|
||||
|
||||
|
|
@ -158,15 +141,14 @@
|
|||
(test (raised-exn-msg (iter)) #rx"empty"))
|
||||
|
||||
(define (decisions #:var [var pick-var]
|
||||
#:nt [nt pick-nt]
|
||||
#:nt [nt pick-nts]
|
||||
#:str [str pick-string]
|
||||
#:num [num pick-number]
|
||||
#:nat [nat pick-natural]
|
||||
#:int [int pick-integer]
|
||||
#:real [real pick-real]
|
||||
#:any [any pick-any]
|
||||
#:seq [seq pick-sequence-length]
|
||||
#:pref [pref pick-preferred-productions])
|
||||
#:seq [seq pick-sequence-length])
|
||||
(define-syntax decision
|
||||
(syntax-rules ()
|
||||
[(_ d) (if (procedure? d) (λ () d) (iterator (quote d) d))]))
|
||||
|
|
@ -179,8 +161,7 @@
|
|||
(define next-real-decision (decision real))
|
||||
(define next-string-decision (decision str))
|
||||
(define next-any-decision (decision any))
|
||||
(define next-sequence-decision (decision seq))
|
||||
(define next-pref-prods-decision (decision pref))))
|
||||
(define next-sequence-decision (decision seq))))
|
||||
|
||||
(define-syntax generate-term/decisions
|
||||
(syntax-rules ()
|
||||
|
|
@ -539,71 +520,6 @@
|
|||
(get-output-string p)
|
||||
(close-output-port p))))
|
||||
|
||||
;; preferred productions
|
||||
(let ([make-pick-nt (λ opt (λ req (apply pick-nt (append req opt))))])
|
||||
(define-language L
|
||||
(e (+ e e) (* e e) 7))
|
||||
(define-language M (e 0) (e-e 1))
|
||||
|
||||
(let ([pats (λ (L) (nt-rhs (car (compiled-lang-lang L))))])
|
||||
(test
|
||||
(generate-term/decisions
|
||||
L e 2 preferred-production-threshold
|
||||
(decisions #:pref (list (λ (L) (make-pref-prods
|
||||
'dont-care
|
||||
(make-immutable-hash `((e ,(car (pats L))))))))
|
||||
#:nt (make-pick-nt (make-random 0 0 0))))
|
||||
'(+ (+ 7 7) (+ 7 7)))
|
||||
(test
|
||||
(generate-term/decisions
|
||||
L any 2 preferred-production-threshold
|
||||
(decisions #:nt (patterns first)
|
||||
#:var (list (λ _ 'x))
|
||||
#:any (list (λ (lang sexp) (values sexp 'sexp)))))
|
||||
'x)
|
||||
(test
|
||||
(generate-term/decisions
|
||||
L any 2 preferred-production-threshold
|
||||
(decisions #:pref (list (λ (L) (make-pref-prods
|
||||
'dont-care
|
||||
(make-immutable-hash `((e ,(car (pats L))))))))
|
||||
#:nt (make-pick-nt (make-random 0 0 0))
|
||||
#:any (list (λ (lang sexp) (values lang 'e)))))
|
||||
'(+ (+ 7 7) (+ 7 7)))
|
||||
(test
|
||||
(generate-term/decisions
|
||||
M (cross e) 2 preferred-production-threshold
|
||||
(decisions #:nt (make-pick-nt (make-random) (λ (att rand) #t))))
|
||||
(term hole))
|
||||
(test
|
||||
(generate-term/decisions
|
||||
M e-e 2 preferred-production-threshold
|
||||
(decisions #:nt (make-pick-nt (make-random) (λ (att rand) #t))))
|
||||
1)
|
||||
|
||||
(test
|
||||
(let ([generated null])
|
||||
(output
|
||||
(λ ()
|
||||
(check-reduction-relation
|
||||
(reduction-relation L (--> e e))
|
||||
(λ (t) (set! generated (cons t generated)))
|
||||
#:decisions (decisions #:nt (make-pick-nt (make-random)
|
||||
(λ (att rand) #t))
|
||||
#:pref (list (λ (_) 'dontcare)
|
||||
(λ (_) 'dontcare)
|
||||
(λ (_) 'dontcare)
|
||||
; size 0 terms prior to this attempt
|
||||
(λ (L) (make-pref-prods
|
||||
'dont-care
|
||||
(make-immutable-hash `((e ,(car (pats L)))))))
|
||||
(λ (L) (make-pref-prods
|
||||
'dont-care
|
||||
(make-immutable-hash `((e ,(cadr (pats L)))))))))
|
||||
#:attempts 5)))
|
||||
generated)
|
||||
'((* 7 7) (+ 7 7) 7 7 7))))
|
||||
|
||||
;; redex-check
|
||||
(let ()
|
||||
(define-language lang
|
||||
|
|
@ -890,89 +806,6 @@
|
|||
(check-metafunction n (λ (_) #t) #:retries 42))
|
||||
#rx"check-metafunction: unable .* in 42"))
|
||||
|
||||
;; custom generators
|
||||
(let ()
|
||||
(define-language L
|
||||
(x variable))
|
||||
|
||||
(test
|
||||
(generate-term
|
||||
L x_1 0
|
||||
#:custom (λ (pat sz i-h acc env att rec def)
|
||||
(match pat
|
||||
['x (values 'x env)]
|
||||
[_ (def acc)])))
|
||||
'x)
|
||||
(test
|
||||
(let/ec k
|
||||
(equal?
|
||||
(generate-term
|
||||
L (x x) 0
|
||||
#:custom (let ([once? #f])
|
||||
(λ (pat sz i-h acc env att rec def)
|
||||
(match pat
|
||||
['x (if once?
|
||||
(k #f)
|
||||
(begin
|
||||
(set! once? #t)
|
||||
(values 'x env)))]
|
||||
[_ (def acc)]))))
|
||||
'(x x)))
|
||||
#t)
|
||||
|
||||
(test
|
||||
(hash-ref
|
||||
(let/ec k
|
||||
(generate-term
|
||||
L (x (x)) 0
|
||||
#:custom (λ (pat sz i-h acc env att rec def)
|
||||
(match pat
|
||||
[(struct binder ('x))
|
||||
(values 'y (hash-set env pat 'y))]
|
||||
[(list (struct binder ('x))) (k env)]
|
||||
[_ (def acc)]))))
|
||||
(make-binder 'x))
|
||||
'y)
|
||||
|
||||
(test
|
||||
(generate-term
|
||||
L (in-hole hole 7) 0
|
||||
#:custom (λ (pat sz i-h acc env att rec def)
|
||||
(match pat
|
||||
[`(in-hole hole 7)
|
||||
(rec 'hole #:contractum 7)]
|
||||
[_ (def acc)])))
|
||||
7)
|
||||
|
||||
(test
|
||||
(let/ec k
|
||||
(generate-term
|
||||
L any 10
|
||||
#:attempt 42
|
||||
#:custom (λ (pat sz i-h acc env att rec def) (k (list sz att)))))
|
||||
'(10 42))
|
||||
|
||||
(test
|
||||
(let/ec k
|
||||
(generate-term
|
||||
L x 10
|
||||
#:custom (λ (pat sz i-h acc env att rec def)
|
||||
(match pat
|
||||
['x (rec 7 #:size 0)]
|
||||
[7 (k sz)]
|
||||
[_ (def att)]))))
|
||||
0)
|
||||
|
||||
(test
|
||||
(generate-term
|
||||
L (q 7) 0
|
||||
#:custom (λ (pat sz i-h acc env att rec def)
|
||||
(match pat
|
||||
['q (rec '(7 7) #:acc 8)]
|
||||
[7 (values (or acc 7) env)]
|
||||
[_ (def att)])))
|
||||
'((8 8) 7)))
|
||||
|
||||
;; parse/unparse-pattern
|
||||
(let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])])
|
||||
(define-language lang (x variable))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user