938 lines
38 KiB
Scheme
938 lines
38 KiB
Scheme
#lang scheme
|
|
|
|
(require "matcher.ss"
|
|
"reduction-semantics.ss"
|
|
"underscore-allowed.ss"
|
|
"term.ss"
|
|
"error.ss"
|
|
"struct.ss"
|
|
(for-syntax "rewrite-side-conditions.ss")
|
|
(for-syntax "term-fn.ss")
|
|
(for-syntax "reduction-semantics.ss")
|
|
(for-syntax "keyword-macros.ss")
|
|
mrlib/tex-table)
|
|
|
|
(define (exotic-choice? [random random]) (= 0 (random 5)))
|
|
(define (use-lang-literal? [random random]) (= 0 (random 20)))
|
|
|
|
(define default-check-attempts 1000)
|
|
|
|
(define ascii-chars-threshold 1000)
|
|
(define tex-chars-threshold 1500)
|
|
(define chinese-chars-threshold 2500)
|
|
|
|
(define (pick-var lang-lits attempt [random random])
|
|
(let ([length (add1 (random-natural 4/5 random))])
|
|
(string->symbol (random-string lang-lits length attempt random))))
|
|
|
|
(define (pick-char attempt [random random])
|
|
(cond [(or (< attempt ascii-chars-threshold) (not (exotic-choice? random)))
|
|
(let ([i (random (add1 (- (char->integer #\z) (char->integer #\a))))]
|
|
[cap? (zero? (random 2))])
|
|
(integer->char (+ i (char->integer (if cap? #\A #\a)))))]
|
|
[(or (< attempt tex-chars-threshold) (not (exotic-choice? random)))
|
|
(let ([i (random (- #x7E #x20 1))]
|
|
[_ (- (char->integer #\_) #x20)])
|
|
(integer->char (+ #x20 (if (= i _) (add1 i) i))))]
|
|
[(or (< attempt chinese-chars-threshold) (not (exotic-choice? random)))
|
|
(car (string->list (pick-from-list (map cadr tex-shortcut-table) random)))]
|
|
[else
|
|
(integer->char (+ #x4E00 (random (- #x9FCF #x4E00))))]))
|
|
|
|
(define (random-string lang-lits length attempt [random 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 random))))))
|
|
|
|
(define (pick-any lang sexp [random random])
|
|
(let ([c-lang (rg-lang-clang lang)]
|
|
[c-sexp (rg-lang-clang sexp)])
|
|
(if (and (not (null? (compiled-lang-lang c-lang))) (zero? (random 5)))
|
|
(values lang (pick-from-list (map nt-name (compiled-lang-lang c-lang)) random))
|
|
(values sexp (nt-name (car (compiled-lang-lang c-sexp)))))))
|
|
|
|
(define (pick-string lang-lits attempt [random random])
|
|
(random-string lang-lits (random-natural 1/5 random) attempt random))
|
|
|
|
(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))))
|
|
|
|
;; Chooses a random (exact) natural number from the "shifted" geometric distribution:
|
|
;; P(random-natural = k) = p(1-p)^k
|
|
;;
|
|
;; P(random-natural >= k) = (1-p)^(k+1)
|
|
;; E(random-natural) = (1-p)/p
|
|
;; Var(random-natural) = (1-p)/p^2
|
|
(define (random-natural p [random random])
|
|
(sub1 (inexact->exact (ceiling (real-part (/ (log (random)) (log (- 1 p))))))))
|
|
|
|
(define (negative? random)
|
|
(zero? (random 2)))
|
|
|
|
(define (random-integer p [random random])
|
|
(* (if (negative? random) -1 1) (random-natural p random)))
|
|
|
|
(define (random-rational p [random random])
|
|
(/ (random-integer p random) (add1 (random-natural p random))))
|
|
|
|
(define (random-real p [random random])
|
|
(* (random) 2 (random-integer p random)))
|
|
|
|
(define (random-complex p [random random])
|
|
(let ([randoms (list random-integer random-rational random-real)])
|
|
(make-rectangular ((pick-from-list randoms random) p random)
|
|
((pick-from-list randoms random) p random))))
|
|
|
|
(define integer-threshold 100)
|
|
(define rational-threshold 500)
|
|
(define real-threshold 1000)
|
|
(define complex-threshold 2000)
|
|
|
|
(define default-retries 100)
|
|
(define retry-threshold (max chinese-chars-threshold complex-threshold))
|
|
(define proportion-before-threshold 9/10)
|
|
(define proportion-at-size 1/10)
|
|
(define post-threshold-incr 50)
|
|
|
|
;; 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
|
|
(/ 1 (+ (max 1 E) 1)))
|
|
|
|
; Determines a size measure for numbers, sequences, etc., using the
|
|
; attempt count.
|
|
(define (attempt->size n)
|
|
(inexact->exact (floor (/ (log (add1 n)) (log 5)))))
|
|
|
|
(define (pick-number attempt #:top-threshold [top-threshold complex-threshold] [random random])
|
|
(let loop ([threshold 0]
|
|
[generator random-natural]
|
|
[levels `((,integer-threshold . ,random-integer)
|
|
(,rational-threshold . ,random-rational)
|
|
(,real-threshold . ,random-real)
|
|
(,complex-threshold . ,random-complex))])
|
|
(if (or (null? levels)
|
|
(< attempt (caar levels))
|
|
(< top-threshold (caar levels))
|
|
(not (exotic-choice? random)))
|
|
(generator (expected-value->p (attempt->size (- attempt threshold))) random)
|
|
(loop (caar levels) (cdar levels) (cdr levels)))))
|
|
|
|
(define (pick-natural attempt [random random])
|
|
(pick-number attempt #:top-threshold 0 random))
|
|
|
|
(define (pick-integer attempt [random random])
|
|
(pick-number attempt #:top-threshold integer-threshold random))
|
|
|
|
(define (pick-real attempt [random random])
|
|
(pick-number attempt #:top-threshold real-threshold random))
|
|
|
|
(define (pick-sequence-length attempt)
|
|
(random-natural (expected-value->p (attempt->size attempt))))
|
|
|
|
(define (zip . lists)
|
|
(apply (curry map list) lists))
|
|
|
|
(define (min-prods nt base-table)
|
|
(let* ([sizes (hash-ref base-table (nt-name nt))]
|
|
[min-size (apply min/f sizes)])
|
|
(map cadr (filter (λ (x) (equal? min-size (car x))) (zip sizes (nt-rhs nt))))))
|
|
|
|
(define-struct rg-lang (clang lits base-cases))
|
|
(define (prepare-lang lang)
|
|
(let ([lits (map symbol->string (compiled-lang-literals lang))]
|
|
[parsed (parse-language lang)])
|
|
(make-rg-lang parsed lits (find-base-cases parsed))))
|
|
|
|
(define-struct (exn:fail:redex:generation-failure exn:fail:redex) ())
|
|
(define (raise-gen-fail who what attempts)
|
|
(let ([str (format "~a: unable to generate ~a in ~a attempt~a"
|
|
who what attempts (if (= attempts 1) "" "s"))])
|
|
(raise (make-exn:fail:redex:generation-failure str (current-continuation-marks)))))
|
|
|
|
(define (generate lang decisions@ what)
|
|
(define-values/invoke-unit decisions@
|
|
(import) (export decisions^))
|
|
|
|
(define ((generate-nt lang base-cases generate retries)
|
|
name cross? size attempt in-hole env)
|
|
(let*-values
|
|
([(term _)
|
|
(generate/pred
|
|
name
|
|
(λ (size attempt)
|
|
(let ([rhs (pick-from-list
|
|
(if (zero? size)
|
|
(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)))])
|
|
(generate (max 0 (sub1 size)) attempt empty-env in-hole (rhs-pattern rhs))))
|
|
(λ (_ env) (mismatches-satisfied? env))
|
|
size attempt retries)])
|
|
term))
|
|
|
|
(define (generate-sequence ellipsis generate env length)
|
|
(define (split-environment env)
|
|
(foldl (λ (var seq-envs)
|
|
(let ([vals (hash-ref env var #f)])
|
|
(if vals
|
|
(map (λ (seq-env val) (hash-set seq-env var val)) seq-envs vals)
|
|
seq-envs)))
|
|
(build-list length (λ (_) #hash())) (ellipsis-vars ellipsis)))
|
|
(define (merge-environments seq-envs)
|
|
(foldl (λ (var env)
|
|
(hash-set env var (map (λ (seq-env) (hash-ref seq-env var)) seq-envs)))
|
|
env (ellipsis-vars ellipsis)))
|
|
(let-values
|
|
([(seq envs)
|
|
(let recur ([envs (split-environment env)])
|
|
(if (null? envs)
|
|
(values null null)
|
|
(let*-values
|
|
([(term env) (generate (car envs) the-hole (ellipsis-pattern ellipsis))]
|
|
[(terms envs) (recur (cdr envs))])
|
|
(values (cons term terms) (cons env envs)))))])
|
|
(values seq (merge-environments envs))))
|
|
|
|
(define (generate/pred name gen pred init-sz init-att retries)
|
|
(let ([pre-threshold-incr
|
|
(ceiling
|
|
(/ (- retry-threshold init-att)
|
|
(* proportion-before-threshold (add1 retries))))]
|
|
[incr-size?
|
|
(λ (remain)
|
|
(zero?
|
|
(modulo (sub1 remain)
|
|
(ceiling (* proportion-at-size
|
|
retries)))))])
|
|
(let retry ([remaining (add1 retries)]
|
|
[size init-sz]
|
|
[attempt init-att])
|
|
(if (zero? remaining)
|
|
(raise-gen-fail what (format "pattern ~a" name) retries)
|
|
(let-values ([(term env) (gen size attempt)])
|
|
(if (pred term env)
|
|
(values term env)
|
|
(retry (sub1 remaining)
|
|
(if (incr-size? remaining) (add1 size) size)
|
|
(+ attempt
|
|
(if (>= attempt retry-threshold)
|
|
post-threshold-incr
|
|
pre-threshold-incr)))))))))
|
|
|
|
(define (generate/prior name env generate)
|
|
(let* ([none (gensym)]
|
|
[prior (hash-ref env name none)])
|
|
(if (eq? prior none)
|
|
(let-values ([(term env) (generate)])
|
|
(values term (hash-set env name term)))
|
|
(values prior env))))
|
|
|
|
(define (mismatches-satisfied? env)
|
|
(let ([groups (make-hasheq)])
|
|
(define (get-group group)
|
|
(hash-ref groups group
|
|
(λ ()
|
|
(let ([vals (make-hash)])
|
|
(hash-set! groups group vals)
|
|
vals))))
|
|
(for/and ([(name val) env])
|
|
(or (not (mismatch? name))
|
|
(let ([prior (get-group (mismatch-group name))])
|
|
(and (not (hash-ref prior val #f))
|
|
(hash-set! prior val #t)))))))
|
|
|
|
(define empty-env #hash())
|
|
|
|
(define (bindings env)
|
|
(make-bindings
|
|
(for/fold ([bindings null]) ([(key val) env])
|
|
(if (binder? key)
|
|
(cons (make-bind (binder-name key) val) bindings)
|
|
bindings))))
|
|
|
|
(define (generate-pat lang sexp retries size attempt env in-hole pat)
|
|
(define recur (curry generate-pat lang sexp retries size attempt))
|
|
(define recur/pat (recur env in-hole))
|
|
(define ((recur/pat/size-attempt pat) size attempt)
|
|
(generate-pat lang sexp retries 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 retries)
|
|
retries))
|
|
|
|
(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 retries)]
|
|
[`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 retries)]
|
|
[`(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 retries)]
|
|
[`(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
|
|
retries
|
|
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)])
|
|
(λ (pat)
|
|
(let ([parsed (reassign-classes (parse-pattern pat lang 'top-level))])
|
|
(λ (size attempt retries)
|
|
(let-values ([(term env)
|
|
(generate/pred
|
|
pat
|
|
(λ (size attempt)
|
|
(generate-pat
|
|
rg-lang
|
|
rg-sexp
|
|
retries
|
|
size
|
|
attempt
|
|
empty-env
|
|
the-hole
|
|
parsed))
|
|
(λ (_ env) (mismatches-satisfied? env))
|
|
size attempt retries)])
|
|
(values term (bindings env))))))))
|
|
|
|
(define-struct base-cases (cross non-cross))
|
|
|
|
;; find-base-cases : (list/c nt) -> base-cases
|
|
(define (find-base-cases lang)
|
|
(define nt-table (make-hash))
|
|
(define changed? #f)
|
|
(define (nt-get nt) (hash-ref nt-table nt 'inf))
|
|
(define (nt-set nt new)
|
|
(let ([old (nt-get nt)])
|
|
(unless (equal? new old)
|
|
(set! changed? #t)
|
|
(hash-set! nt-table nt new))))
|
|
|
|
(define ((process-nt cross?) nt)
|
|
(nt-set (cons cross? (nt-name nt)) (apply min/f (map process-rhs (nt-rhs nt)))))
|
|
|
|
(define (process-rhs rhs)
|
|
(let ([nts (rhs->nts (rhs-pattern rhs))])
|
|
(if (null? nts)
|
|
0
|
|
(add1/f (apply max/f (map nt-get nts))))))
|
|
|
|
;; rhs->path : pattern -> (listof (cons/c boolean symbol))
|
|
;; determines all of the non-terminals in a pattern
|
|
(define (rhs->nts pat)
|
|
(let ([nts '()])
|
|
(let loop ([pat pat])
|
|
(match pat
|
|
[(? symbol? pat)
|
|
(when ((is-nt? lang) (symbol->nt pat))
|
|
(set! nts (cons (cons #f (symbol->nt pat)) nts)))]
|
|
[`(cross ,(? symbol? x-nt))
|
|
(set! nts (cons (cons #t x-nt) nts))]
|
|
[`(variable-except ,s ...) (void)]
|
|
[`(variable-prefix ,p) (void)]
|
|
[`() (void)]
|
|
[(struct ellipsis (_ p _ _))
|
|
(loop p)]
|
|
[`(,a . ,b)
|
|
(loop a)
|
|
(loop b)]
|
|
[_ (void)]))
|
|
nts))
|
|
|
|
;; build-table : (listof nt) -> hash
|
|
(define (build-table nts)
|
|
(let ([tbl (make-hasheq)])
|
|
(for-each
|
|
(λ (nt) (hash-set! tbl (nt-name nt) (map process-rhs (nt-rhs nt))))
|
|
nts)
|
|
tbl))
|
|
|
|
(let loop ()
|
|
(set! changed? #f)
|
|
(for-each (process-nt #f) (compiled-lang-lang lang))
|
|
(for-each (process-nt #t) (compiled-lang-cclang lang))
|
|
(when changed?
|
|
(loop)))
|
|
|
|
(make-base-cases
|
|
(build-table (compiled-lang-cclang lang))
|
|
(build-table (compiled-lang-lang lang))))
|
|
|
|
(define min/f
|
|
(case-lambda
|
|
[(a) a]
|
|
[(a b)
|
|
(cond
|
|
[(eq? a 'inf) b]
|
|
[(eq? b 'inf) a]
|
|
[else (min a b)])]
|
|
[(a b . c) (min/f a (apply min/f b c))]))
|
|
(define max/f
|
|
(case-lambda
|
|
[(a) a]
|
|
[(a b)
|
|
(cond
|
|
[(eq? a 'inf) a]
|
|
[(eq? b 'inf) b]
|
|
[else (max a b)])]
|
|
[(a b . c) (max/f a (apply max/f b c))]))
|
|
(define (add1/f a) (if (eq? a 'inf) 'inf (+ a 1)))
|
|
|
|
;; is-nt? : compiled-lang any -> boolean
|
|
(define ((is-nt? lang) x)
|
|
(and (hash-ref (compiled-lang-ht lang) x #f) #t))
|
|
|
|
;; built-in? : any -> boolean
|
|
(define (built-in? x)
|
|
(and (memq x underscore-allowed) #t))
|
|
|
|
;; nt-by-name : lang symbol boolean -> nt
|
|
(define (nt-by-name lang name cross?)
|
|
(findf (λ (nt) (eq? name (nt-name nt)))
|
|
(if cross?
|
|
(compiled-lang-cclang lang)
|
|
(compiled-lang-lang lang))))
|
|
|
|
(define named-nt-rx #rx"^([^_]+)_[^_]*$")
|
|
(define mismatch-nt-rx #rx"([^_]+)_!_[^_]*$")
|
|
(define named-ellipsis-rx #rx"^\\.\\.\\._[^_]*$")
|
|
(define mismatch-ellipsis-rx #rx"^\\.\\.\\._!_[^_]*$")
|
|
|
|
;; symbol-match : regexp -> any -> (or/c false symbol)
|
|
;; Returns the sub-symbol matching the sub-pattern inside
|
|
;; the first capturing parens.
|
|
(define ((symbol-match rx) x)
|
|
(and (symbol? x)
|
|
(let ([match (regexp-match rx (symbol->string x))])
|
|
(and match (cadr match) (string->symbol (cadr match))))))
|
|
|
|
(define-struct class (id) #:inspector (make-inspector))
|
|
(define-struct mismatch (id group) #:inspector (make-inspector))
|
|
(define-struct binder (name) #:inspector (make-inspector))
|
|
|
|
;; name: (or/c symbol? mismatch?)
|
|
;; The generator records `name' in the environment when generating an ellipsis,
|
|
;; to enforce sequence length constraints.
|
|
;; class: class?
|
|
;; When one binding appears under two (non-nested) ellipses, the sequences generated
|
|
;; must have the same length; `class' groups ellipses to reflect this constraint.
|
|
;; var: (list/c (or/c symbol? class? mismatch? binder?))
|
|
;; the bindings within an ellipses, used to split and merge the environment before
|
|
;; and after generating an ellipsis
|
|
(define-struct ellipsis (name pattern class vars) #:inspector (make-inspector))
|
|
|
|
;; parse-pattern : pattern compiled-lang (or/c 'cross 'top-level 'grammar) -> parsed-pattern
|
|
;; Turns "pat ...", "pat ..._id", and "pat ..._!_id" into ellipsis structs,
|
|
;; "nt_!_id" into mismatch structs, "nt_id" into binder structs, and
|
|
;; "nt/underscore-allowed" in top-level patterns into binder structs.
|
|
(define (parse-pattern pattern lang mode)
|
|
(define (recur pat vars)
|
|
(match pat
|
|
[(or (app (symbol-match named-nt-rx) (or (? (is-nt? lang)) (? built-in?)))
|
|
(and (? (λ (_) (eq? mode 'top-level))) (or (? (is-nt? lang)) (? built-in?))))
|
|
(let ([b (make-binder pat)])
|
|
(values b (cons b vars)))]
|
|
[(app (symbol-match mismatch-nt-rx) (or (? (is-nt? lang)) (? built-in?)))
|
|
(let ([mismatch (make-mismatch (gensym) pat)])
|
|
(values mismatch (cons mismatch vars)))]
|
|
[`(name ,name ,sub-pat)
|
|
(let-values ([(parsed vars) (recur sub-pat vars)])
|
|
(values `(name ,name ,parsed) (cons (make-binder name) vars)))]
|
|
[(list-rest sub-pat (and (? symbol?) (app symbol->string (regexp named-ellipsis-rx)) name) rest)
|
|
(let*-values ([(sub-pat-parsed sub-pat-vars) (recur sub-pat null)]
|
|
[(seq) (make-ellipsis name sub-pat-parsed (make-class name) sub-pat-vars)]
|
|
[(vars) (append (list* name (make-class name) sub-pat-vars) vars)]
|
|
[(rest-parsed vars) (recur rest vars)])
|
|
(values (cons seq rest-parsed) vars))]
|
|
[(list-rest sub-pat '... rest)
|
|
(let*-values ([(sub-pat-parsed sub-pat-vars) (recur sub-pat null)]
|
|
[(class) (make-class (gensym))]
|
|
[(seq) (make-ellipsis '... sub-pat-parsed class sub-pat-vars)]
|
|
[(rest-parsed vars) (recur rest (cons class (append sub-pat-vars vars)))])
|
|
(values (cons seq rest-parsed) vars))]
|
|
[(list-rest sub-pat (and (? symbol?) (app symbol->string (regexp mismatch-ellipsis-rx)) name) rest)
|
|
(let*-values ([(sub-pat-parsed sub-pat-vars) (recur sub-pat null)]
|
|
[(mismatch) (make-mismatch (gensym) name)]
|
|
[(class) (make-class (gensym))]
|
|
[(seq) (make-ellipsis mismatch sub-pat-parsed class sub-pat-vars)]
|
|
[(vars) (append (list* class mismatch sub-pat-vars) vars)]
|
|
[(rest-parsed vars) (recur rest vars)])
|
|
(values (cons seq rest-parsed) vars))]
|
|
[(and (? (λ (_) (not (eq? mode 'cross)))) `(cross ,(and (? (is-nt? lang)) nt)))
|
|
(let ([nt-str (symbol->string nt)])
|
|
(values `(cross ,(string->symbol (string-append nt-str "-" nt-str))) vars))]
|
|
[`(side-condition ,pat ,guard ,guard-src-loc)
|
|
(let-values ([(parsed vars) (recur pat vars)])
|
|
(values `(side-condition ,parsed ,guard ,guard-src-loc) vars))]
|
|
[(cons first rest)
|
|
(let-values ([(first-parsed vars) (recur first vars)])
|
|
(let-values ([(rest-parsed vars) (recur rest vars)])
|
|
(values (cons first-parsed rest-parsed) vars)))]
|
|
[_ (values pat vars)]))
|
|
(let-values ([(parsed _) (recur pattern null)])
|
|
parsed))
|
|
|
|
;; parse-language: compiled-lang -> compiled-lang
|
|
(define (parse-language lang)
|
|
(define ((parse-nt mode) nt)
|
|
(make-nt (nt-name nt) (map (parse-rhs mode) (nt-rhs nt))))
|
|
(define ((parse-rhs mode) rhs)
|
|
(make-rhs (reassign-classes (parse-pattern (rhs-pattern rhs) lang mode))))
|
|
|
|
(struct-copy
|
|
compiled-lang lang
|
|
[lang (map (parse-nt 'grammar) (compiled-lang-lang lang))]
|
|
[cclang (map (parse-nt 'cross) (compiled-lang-cclang lang))]))
|
|
|
|
;; unparse-pattern: parsed-pattern -> pattern
|
|
(define unparse-pattern
|
|
(match-lambda
|
|
[(struct binder (name)) name]
|
|
[(struct mismatch (_ group)) group]
|
|
[(list-rest (struct ellipsis (name sub-pat _ _)) rest)
|
|
(let ([ellipsis (if (mismatch? name) (mismatch-group name) name)])
|
|
(list* (unparse-pattern sub-pat) ellipsis (unparse-pattern rest)))]
|
|
[(cons first rest)
|
|
(cons (unparse-pattern first) (unparse-pattern rest))]
|
|
[else else]))
|
|
|
|
;; class-reassignments : parsed-pattern -> hash[sym -o> sym]
|
|
(define (class-reassignments pattern)
|
|
; union-find w/o balancing or path compression (at least for now)
|
|
(define (union e f sets)
|
|
(hash-set sets (find f sets) (find e sets)))
|
|
(define (find e sets)
|
|
(let recur ([chd e] [par (hash-ref sets e #f)])
|
|
(if (and par (not (eq? chd par))) (recur par (hash-ref sets par #f)) chd)))
|
|
|
|
(let* ([last-contexts (make-hasheq)]
|
|
[record-binder
|
|
(λ (pat under assignments)
|
|
(if (null? under)
|
|
assignments
|
|
(let ([last (hash-ref last-contexts pat #f)])
|
|
(if last
|
|
(foldl (λ (cur last asgns) (union cur last asgns)) assignments under last)
|
|
(begin
|
|
(hash-set! last-contexts pat under)
|
|
assignments)))))]
|
|
[assignments
|
|
(let recur ([pat pattern] [under null] [assignments #hasheq()])
|
|
(match pat
|
|
;; `(name ,id ,sub-pat) not considered, since bindings introduced
|
|
;; by name must be unique.
|
|
[(struct binder (name))
|
|
(record-binder name under assignments)]
|
|
[(struct ellipsis (name sub-pat (struct class (cls)) _))
|
|
(recur sub-pat (cons cls under)
|
|
(if (and (symbol? name) (regexp-match named-ellipsis-rx (symbol->string name)))
|
|
(record-binder name under assignments)
|
|
assignments))]
|
|
[(? list?)
|
|
(foldl (λ (pat asgns) (recur pat under asgns)) assignments pat)]
|
|
[_ assignments]))])
|
|
(make-immutable-hasheq (hash-map assignments (λ (cls _) (cons cls (find cls assignments)))))))
|
|
|
|
(define (reassign-classes pattern)
|
|
(let* ([reassignments (class-reassignments pattern)]
|
|
[rewrite (λ (c) (make-class (hash-ref reassignments (class-id c) (class-id c))))])
|
|
(let recur ([pat pattern])
|
|
(match pat
|
|
[(struct ellipsis (name sub-pat class vars))
|
|
(make-ellipsis name (recur sub-pat) (rewrite class)
|
|
(map (λ (v) (if (class? v) (rewrite v) v)) vars))]
|
|
[(? list?) (map recur pat)]
|
|
[_ pat]))))
|
|
|
|
;; used in generating the `any' pattern
|
|
(define-language sexp (sexp variable string number hole (sexp ...)))
|
|
|
|
(define-for-syntax (metafunc name)
|
|
(let ([tf (syntax-local-value name (λ () #f))])
|
|
(and (term-fn? tf) (term-fn-get-id tf))))
|
|
|
|
(define-for-syntax (metafunc/err name stx)
|
|
(let ([m (metafunc name)])
|
|
(if m m (raise-syntax-error #f "not a metafunction" stx name))))
|
|
|
|
(define (assert-nat name x)
|
|
(if (and (integer? x) (>= x 0))
|
|
x
|
|
(raise-type-error name "natural number" x)))
|
|
(define (assert-rel name x)
|
|
(if (reduction-relation? x)
|
|
x
|
|
(raise-type-error 'redex-check "reduction-relation" x)))
|
|
|
|
(define-for-syntax (term-generator lang pat decisions@ what)
|
|
(with-syntax ([pattern
|
|
(rewrite-side-conditions/check-errs
|
|
(language-id-nts lang what)
|
|
what #t pat)])
|
|
#`((generate #,lang #,decisions@ '#,what) `pattern)))
|
|
|
|
(define-syntax (generate-term stx)
|
|
(syntax-case stx ()
|
|
[(name lang pat size . kw-args)
|
|
(with-syntax ([(attempt retries)
|
|
(parse-kw-args `((#:attempt-num . 1)
|
|
(#:retries . ,#'default-retries))
|
|
(syntax kw-args)
|
|
stx)])
|
|
(syntax/loc stx
|
|
((generate-term lang pat) size #:attempt-num attempt #:retries retries)))]
|
|
[(name lang pat)
|
|
(with-syntax ([make-gen (term-generator #'lang
|
|
#'pat
|
|
#'(generation-decisions)
|
|
(syntax-e #'name))])
|
|
(syntax/loc stx
|
|
(let ([generate make-gen])
|
|
(λ (size #:attempt-num [attempt-num 1] #:retries [retries default-retries])
|
|
(let ([att (assert-nat 'name attempt-num)]
|
|
[ret (assert-nat 'name retries)])
|
|
(let-values ([(term _) (generate size att ret)])
|
|
term))))))]))
|
|
|
|
(define-for-syntax (show-message stx)
|
|
(syntax-case stx ()
|
|
[(what . _)
|
|
(identifier? #'what)
|
|
(with-syntax ([loc (if (and (path? (syntax-source stx))
|
|
(syntax-line stx))
|
|
(format "~a:~a"
|
|
(path->string (syntax-source stx))
|
|
(syntax-line stx))
|
|
#f)])
|
|
#`(λ (msg)
|
|
(fprintf
|
|
(current-output-port)
|
|
"~a: ~a~a"
|
|
'what (if loc (string-append loc "\n") "") msg)))]))
|
|
|
|
(define-syntax (redex-check stx)
|
|
(syntax-case stx ()
|
|
[(_ lang pat property . kw-args)
|
|
(let-values ([(names names/ellipses)
|
|
(extract-names (language-id-nts #'lang 'redex-check)
|
|
'redex-check #t #'pat)]
|
|
[(attempts-stx source-stx retries-stx)
|
|
(apply values
|
|
(parse-kw-args `((#:attempts . ,#'default-check-attempts)
|
|
(#:source . #f)
|
|
(#:retries . ,#'default-retries))
|
|
(syntax kw-args)
|
|
stx))])
|
|
(with-syntax ([(name ...) names]
|
|
[(name/ellipses ...) names/ellipses]
|
|
[show (show-message stx)])
|
|
(with-syntax ([property (syntax
|
|
(λ (_ bindings)
|
|
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
|
|
property)))])
|
|
(quasisyntax/loc stx
|
|
(let ([att (assert-nat 'redex-check #,attempts-stx)]
|
|
[ret (assert-nat 'redex-check #,retries-stx)])
|
|
(unsyntax
|
|
(if source-stx
|
|
#`(let-values ([(metafunc/red-rel num-cases)
|
|
#,(cond [(and (identifier? source-stx) (metafunc source-stx))
|
|
=> (λ (x) #`(values #,x (length (metafunc-proc-cases #,x))))]
|
|
[else
|
|
#`(let ([r (assert-rel 'redex-check #,source-stx)])
|
|
(values r (length (reduction-relation-make-procs r))))])])
|
|
(check-lhs-pats
|
|
lang
|
|
metafunc/red-rel
|
|
property
|
|
random-decisions@
|
|
(max 1 (floor (/ att num-cases)))
|
|
ret
|
|
'redex-check
|
|
show
|
|
(test-match lang pat)
|
|
(λ (generated) (redex-error 'redex-check "~s does not match ~s" generated 'pat))))
|
|
#`(check-prop
|
|
#,(term-generator #'lang #'pat #'random-decisions@ 'redex-check)
|
|
property att ret show)))
|
|
(void))))))]))
|
|
|
|
(define (format-attempts a)
|
|
(format "~a attempt~a" a (if (= 1 a) "" "s")))
|
|
|
|
(define (check-prop generator property attempts retries show)
|
|
(when (check generator property attempts retries show)
|
|
(show (format "no counterexamples in ~a\n"
|
|
(format-attempts attempts)))))
|
|
|
|
(define (check generator property attempts retries show
|
|
#:source [source #f]
|
|
#:match [match #f]
|
|
#:match-fail [match-fail #f])
|
|
(let loop ([remaining attempts])
|
|
(if (zero? remaining)
|
|
#t
|
|
(let ([attempt (add1 (- attempts remaining))])
|
|
(let-values ([(term bindings) (generator (attempt->size attempt) attempt retries)])
|
|
(if (andmap (λ (bindings)
|
|
(with-handlers
|
|
([exn:fail?
|
|
(λ (exn)
|
|
(show
|
|
(format "checking ~s raises an exception\n" term))
|
|
(raise exn))])
|
|
(property term bindings)))
|
|
(cond [(and match match-fail (match term))
|
|
=> (curry map (compose make-bindings match-bindings))]
|
|
[match (match-fail term)]
|
|
[else (list bindings)]))
|
|
(loop (sub1 remaining))
|
|
(begin
|
|
(show
|
|
(format "counterexample found after ~a~a:\n"
|
|
(format-attempts attempt)
|
|
(if source (format " with ~a" source) "")))
|
|
(pretty-print term (current-output-port))
|
|
#f)))))))
|
|
|
|
(define-syntax (check-metafunction-contract stx)
|
|
(syntax-case stx ()
|
|
[(_ name . kw-args)
|
|
(identifier? #'name)
|
|
(with-syntax ([m (metafunc/err #'name stx)]
|
|
[(attempts retries)
|
|
(parse-kw-args `((#:attempts . ,#'default-check-attempts)
|
|
(#:retries . ,#'default-retries))
|
|
(syntax kw-args)
|
|
stx)]
|
|
[show (show-message stx)])
|
|
(syntax/loc stx
|
|
(let ([lang (metafunc-proc-lang m)]
|
|
[dom (metafunc-proc-dom-pat m)]
|
|
[decisions@ (generation-decisions)]
|
|
[att (assert-nat 'check-metafunction-contract attempts)])
|
|
(check-prop
|
|
((generate lang decisions@ 'check-metafunction-contract)
|
|
(if dom dom '(any (... ...))))
|
|
(λ (t _)
|
|
(with-handlers ([exn:fail:redex? (λ (_) #f)])
|
|
(begin (term (name ,@t)) #t)))
|
|
att
|
|
retries
|
|
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@ what)])
|
|
(let-values ([(pats srcs)
|
|
(cond [(metafunc-proc? mf/rr)
|
|
(values (map metafunc-case-lhs-pat (metafunc-proc-cases mf/rr))
|
|
(metafunction-srcs mf/rr))]
|
|
[(reduction-relation? mf/rr)
|
|
(values (map (λ (rwp) ((rewrite-proc-lhs rwp) lang)) (reduction-relation-make-procs mf/rr))
|
|
(reduction-relation-srcs mf/rr))])])
|
|
(when (for/and ([pat pats] [src srcs])
|
|
(with-handlers ([exn:fail:redex:generation-failure?
|
|
; Produce an error message that blames the LHS as a whole.
|
|
(λ (_)
|
|
(raise-gen-fail what (format "LHS of ~a" src) retries))])
|
|
(check
|
|
(lang-gen pat)
|
|
prop
|
|
attempts
|
|
retries
|
|
show
|
|
#:source src
|
|
#:match match
|
|
#:match-fail match-fail)))
|
|
(show
|
|
(format "no counterexamples in ~a (with each clause)\n"
|
|
(format-attempts attempts)))))))
|
|
|
|
(define-syntax (check-metafunction stx)
|
|
(syntax-case stx ()
|
|
[(_ name property . kw-args)
|
|
(with-syntax ([m (metafunc/err #'name stx)]
|
|
[(attempts retries)
|
|
(parse-kw-args `((#:attempts . , #'default-check-attempts)
|
|
(#:retries . ,#'default-retries))
|
|
(syntax kw-args)
|
|
stx)]
|
|
[show (show-message stx)])
|
|
(syntax/loc stx
|
|
(let ([att (assert-nat 'check-metafunction attempts)]
|
|
[ret (assert-nat 'check-metafunction retries)])
|
|
(check-lhs-pats
|
|
(metafunc-proc-lang m)
|
|
m
|
|
(λ (term _) (property term))
|
|
(generation-decisions)
|
|
att
|
|
ret
|
|
'check-metafunction
|
|
show))))]))
|
|
|
|
(define (reduction-relation-srcs r)
|
|
(map (λ (proc) (or (rewrite-proc-name proc)
|
|
(format "clause at ~a" (rewrite-proc-lhs-src proc))))
|
|
(reduction-relation-make-procs r)))
|
|
|
|
(define (metafunction-srcs m)
|
|
(map (compose (curry format "clause at ~a") metafunc-case-src-loc)
|
|
(metafunc-proc-cases m)))
|
|
|
|
(define-syntax (check-reduction-relation stx)
|
|
(syntax-case stx ()
|
|
[(_ relation property . kw-args)
|
|
(with-syntax ([(attempts retries decisions@)
|
|
(parse-kw-args `((#:attempts . , #'default-check-attempts)
|
|
(#:retries . ,#'default-retries)
|
|
(#:decisions . ,#'random-decisions@))
|
|
(syntax kw-args)
|
|
stx)]
|
|
[show (show-message stx)])
|
|
(syntax/loc stx
|
|
(let ([att attempts]
|
|
[ret (assert-nat 'check-reduction-relation retries)]
|
|
[rel (assert-rel 'check-reduction-relation relation)])
|
|
(check-lhs-pats
|
|
(reduction-relation-lang rel)
|
|
rel
|
|
(λ (term _) (property term))
|
|
decisions@
|
|
attempts
|
|
retries
|
|
'check-reduction-relation
|
|
show))))]))
|
|
|
|
(define-signature decisions^
|
|
(next-variable-decision
|
|
next-number-decision
|
|
next-natural-decision
|
|
next-integer-decision
|
|
next-real-decision
|
|
next-non-terminal-decision
|
|
next-sequence-decision
|
|
next-any-decision
|
|
next-string-decision))
|
|
|
|
(define random-decisions@
|
|
(unit (import) (export decisions^)
|
|
(define (next-variable-decision) pick-var)
|
|
(define (next-number-decision) pick-number)
|
|
(define (next-natural-decision) pick-natural)
|
|
(define (next-integer-decision) pick-integer)
|
|
(define (next-real-decision) pick-real)
|
|
(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 generation-decisions (make-parameter random-decisions@))
|
|
|
|
(provide redex-check
|
|
generate-term
|
|
check-metafunction-contract
|
|
check-reduction-relation
|
|
check-metafunction
|
|
exn:fail:redex:generation-failure?)
|
|
|
|
(provide (struct-out ellipsis)
|
|
(struct-out mismatch)
|
|
(struct-out class)
|
|
(struct-out binder)
|
|
(struct-out base-cases))
|
|
|
|
(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
|
|
retry-threshold proportion-before-threshold post-threshold-incr
|
|
is-nt? nt-by-name min-prods
|
|
generation-decisions decisions^
|
|
random-string
|
|
sexp find-base-cases)
|