From eebe5b2e2b40aabdcc6e665f661dd40064770304 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Mon, 11 Oct 2010 13:34:16 +0200 Subject: [PATCH] 2nd attempt at generators for records/structs. This time, with feeling. --- .../deinprogramm/define-record-procedures.rkt | 3 +- .../deinprogramm/define-record-procedures.scm | 19 +++++++++--- .../deinprogramm/quickcheck/quickcheck.rkt | 2 ++ .../deinprogramm/quickcheck/quickcheck.scm | 30 ++++++++++++++----- .../deinprogramm/signature/signature-unit.rkt | 20 ++++++++----- collects/deinprogramm/signature/signature.rkt | 2 +- collects/lang/private/teach.rkt | 21 +++++++++---- 7 files changed, 70 insertions(+), 27 deletions(-) diff --git a/collects/deinprogramm/define-record-procedures.rkt b/collects/deinprogramm/define-record-procedures.rkt index e0d0297d86..f4d20f511c 100644 --- a/collects/deinprogramm/define-record-procedures.rkt +++ b/collects/deinprogramm/define-record-procedures.rkt @@ -12,7 +12,8 @@ mzlib/pretty deinprogramm/signature/signature deinprogramm/signature/signature-german - deinprogramm/signature/signature-syntax) + deinprogramm/signature/signature-syntax + (only-in deinprogramm/quickcheck/quickcheck arbitrary-record)) (require (for-syntax scheme/base) (for-syntax deinprogramm/syntax-checkers) diff --git a/collects/deinprogramm/define-record-procedures.scm b/collects/deinprogramm/define-record-procedures.scm index 6f6798cf01..175c04bd2e 100644 --- a/collects/deinprogramm/define-record-procedures.scm +++ b/collects/deinprogramm/define-record-procedures.scm @@ -183,10 +183,21 @@ component-signature ...))) ;; lazy signatures #'(define (?signature-constructor-name ?param ...) - (make-lazy-wrap-signature '?type-name #t - type-descriptor raw-predicate - (list ?param ...) - #'?type-name))) + (let* ((sigs (list ?param ...)) + (sig + (make-lazy-wrap-signature '?type-name #t + type-descriptor raw-predicate + sigs + #'?type-name))) + (let ((arbs (map signature-arbitrary sigs))) + (when (andmap values arbs) + (set-signature-arbitrary! + sig + (apply arbitrary-record + ?constructor + (list raw-accessor-proc ...) + arbs)))) + sig))) 'stepper-skip-completely #t))) #'(begin diff --git a/collects/deinprogramm/quickcheck/quickcheck.rkt b/collects/deinprogramm/quickcheck/quickcheck.rkt index 8e3c2f0a6f..2e34d72928 100644 --- a/collects/deinprogramm/quickcheck/quickcheck.rkt +++ b/collects/deinprogramm/quickcheck/quickcheck.rkt @@ -13,6 +13,7 @@ arbitrary-pair arbitrary-list arbitrary-vector + arbitrary-tuple arbitrary-record arbitrary-string arbitrary-ascii-string arbitrary-printable-ascii-string arbitrary-symbol @@ -26,6 +27,7 @@ collect ) (require srfi/9 + racket/promise "random.ss") (provide exn:assertion-violation? diff --git a/collects/deinprogramm/quickcheck/quickcheck.scm b/collects/deinprogramm/quickcheck/quickcheck.scm index 107a2be414..a01852eb4e 100644 --- a/collects/deinprogramm/quickcheck/quickcheck.scm +++ b/collects/deinprogramm/quickcheck/quickcheck.scm @@ -39,7 +39,7 @@ (define choose-ascii-letter (lift->generator (lambda (i) (string-ref - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" i)) (choose-integer 0 51))) (define choose-printable-ascii-char @@ -163,10 +163,10 @@ (define generator-bind >>=) (define generator-sequence sequence) -; (list (generator a)) -> (generator a) +; (list (promise (generator a))) -> (generator a) (define (choose-mixed gens) (>>= (choose-one-of gens) - values)) + force)) ; (list (pair int (generator a))) -> (generator a) (define (choose-with-frequencies lis) @@ -272,17 +272,17 @@ (denominator fr) gen)))))) -(define (arbitrary-mixed pred+arbitrary-list) +(define (arbitrary-mixed pred+arbitrary-promise-list) (make-arbitrary (choose-mixed (map (lambda (p) - (arbitrary-generator (cdr p))) - pred+arbitrary-list)) + (delay (arbitrary-generator (force (cdr p))))) + pred+arbitrary-promise-list)) (lambda (val gen) - (let loop ((lis pred+arbitrary-list) (n 0)) + (let loop ((lis pred+arbitrary-promise-list) (n 0)) (cond ((null? lis) (assertion-violation 'arbitrary-mixed "value matches none of the predicates" - val pred+arbitrary-list)) + val pred+arbitrary-promise-list)) (((caar lis) val) (variant n gen)) (else @@ -327,6 +327,20 @@ (recur (cdr arbitrary-els) (cdr lis)))))))) +(define (arbitrary-record construct accessors . arbitrary-els) + (make-arbitrary (apply lift->generator + construct + (map arbitrary-generator arbitrary-els)) + (lambda (rec gen) + (let recur ((arbitrary-els arbitrary-els) + (lis (map (lambda (accessor) (accessor rec)) accessors))) + (if (null? arbitrary-els) + gen + ((arbitrary-transformer (car arbitrary-els)) + (car lis) + (recur (cdr arbitrary-els) + (cdr lis)))))))) + (define (arbitrary-sequence choose-sequence sequence->list arbitrary-el) (make-arbitrary (sized (lambda (n) diff --git a/collects/deinprogramm/signature/signature-unit.rkt b/collects/deinprogramm/signature/signature-unit.rkt index 5f968bc36c..df0c92f833 100644 --- a/collects/deinprogramm/signature/signature-unit.rkt +++ b/collects/deinprogramm/signature/signature-unit.rkt @@ -207,14 +207,18 @@ (delay (make-mixed-info (force alternative-signatures-promise))) #:arbitrary-promise (delay - (let ((arbitraries (map force (map signature-arbitrary-promise (force alternative-signatures-promise))))) - (if (andmap values arbitraries) - (arbitrary-mixed - (map (lambda (sig arb) - (cons (signature->predicate sig) - arb)) - (force alternative-signatures-promise) arbitraries)) - #f))) + (let* ((arbitrary-promises (map signature-arbitrary-promise alternative-signatures)) + (raising-promises + (map (lambda (prm) + (delay + (or (force prm) + (error "Signatur hat keinen Generator")))) ; #### src location + arbitrary-promises))) + (arbitrary-mixed + (map (lambda (sig arbp) + (cons (signature->predicate sig) + arbp)) + alternative-signatures raising-promises)))) #:=?-proc (lambda (this-info other-info) (and (mixed-info? other-info) diff --git a/collects/deinprogramm/signature/signature.rkt b/collects/deinprogramm/signature/signature.rkt index 02dfda1637..6d26eba234 100644 --- a/collects/deinprogramm/signature/signature.rkt +++ b/collects/deinprogramm/signature/signature.rkt @@ -58,7 +58,7 @@ (display "#" port))))) (define (make-signature name enforcer syntax-promise - #:arbitrary-promise (arbitrary-promise #f) + #:arbitrary-promise (arbitrary-promise (delay #f)) #:info-promise (info-promise (delay #f)) #:<=?-proc (<=?-proc (lambda (this-info other-info) diff --git a/collects/lang/private/teach.rkt b/collects/lang/private/teach.rkt index 72b59545fd..9506c26149 100644 --- a/collects/lang/private/teach.rkt +++ b/collects/lang/private/teach.rkt @@ -894,11 +894,22 @@ (combined (at name_ (predicate raw-predicate)) (at field_ (signature:property getter-name field_/no-loc)) ...))) #`(define (#,parametric-signature-name field_ ...) - (make-lazy-wrap-signature 'name_ #t - type-descriptor - raw-predicate - (list field_/no-loc ...) - #'name_))) + (let* ((sigs (list field_/no-loc ...)) + (sig + (make-lazy-wrap-signature 'name_ #t + type-descriptor + raw-predicate + sigs + #'name_))) + (let ((arbs (map signature-arbitrary sigs))) + (when (andmap values arbs) + (set-signature-arbitrary! + sig + (apply arbitrary-record + #,constructor-name + (list #,@getter-names) + arbs)))) + sig))) (values #,signature-name #,parametric-signature-name proc-name ...))) 'stepper-define-struct-hint