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..dc7afb8fa3 100644 --- a/collects/deinprogramm/define-record-procedures.scm +++ b/collects/deinprogramm/define-record-procedures.scm @@ -183,10 +183,17 @@ 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 arbs)))) + sig))) 'stepper-skip-completely #t))) #'(begin diff --git a/collects/deinprogramm/quickcheck/quickcheck.rkt b/collects/deinprogramm/quickcheck/quickcheck.rkt index 8e3c2f0a6f..a2e814275c 100644 --- a/collects/deinprogramm/quickcheck/quickcheck.rkt +++ b/collects/deinprogramm/quickcheck/quickcheck.rkt @@ -12,6 +12,7 @@ arbitrary-mixed arbitrary-one-of arbitrary-pair arbitrary-list + arbitrary-tuple arbitrary-record arbitrary-vector arbitrary-string arbitrary-ascii-string arbitrary-printable-ascii-string diff --git a/collects/deinprogramm/quickcheck/quickcheck.scm b/collects/deinprogramm/quickcheck/quickcheck.scm index 107a2be414..cf839a82f5 100644 --- a/collects/deinprogramm/quickcheck/quickcheck.scm +++ b/collects/deinprogramm/quickcheck/quickcheck.scm @@ -312,20 +312,30 @@ (coarbitrary arbitrary-cdr (cdr p) gen))))) +(define (make-tuple-transformer arbitrary-els) + (lambda (lis gen) + (let recur ((arbitrary-els arbitrary-els) + (lis lis)) + (if (null? arbitrary-els) + gen + ((arbitrary-transformer (car arbitrary-els)) + (car lis) + (recur (cdr arbitrary-els) + (cdr lis))))))) + ; a tuple is just a non-uniform list (define (arbitrary-tuple . arbitrary-els) (make-arbitrary (apply lift->generator list (map arbitrary-generator arbitrary-els)) - (lambda (lis gen) - (let recur ((arbitrary-els arbitrary-els) - (lis lis)) - (if (null? arbitrary-els) - gen - ((arbitrary-transformer (car arbitrary-els)) - (car lis) - (recur (cdr arbitrary-els) - (cdr lis)))))))) + (make-tuple-transformer arbitrary-els))) + +; like a tuple, just with a different constructor +(define (arbitrary-record make . arbitrary-els) + (make-arbitrary (apply lift->generator + make + (map arbitrary-generator arbitrary-els)) + (make-tuple-transformer arbitrary-els))) (define (arbitrary-sequence choose-sequence sequence->list arbitrary-el) (make-arbitrary (sized diff --git a/collects/deinprogramm/scribblings/DMdA-beginner.scrbl b/collects/deinprogramm/scribblings/DMdA-beginner.scrbl index ce37b4da5a..1ea03d1222 100644 --- a/collects/deinprogramm/scribblings/DMdA-beginner.scrbl +++ b/collects/deinprogramm/scribblings/DMdA-beginner.scrbl @@ -291,9 +291,10 @@ Dieser Testfall überprüft experimentell, ob die @tech{Eigenschaft} @emph{Wichtig:} @scheme[check-property] funktioniert nur für Eigenschaften, bei denen aus den Signaturen sinnvoll Werte generiert werden können. Dies ist für die meisten eingebauten Signaturen der -Fall, aber nicht für Signaturvariablen und Signaturen, die mit @scheme[predicate], -@scheme[property] oder @scheme[define-record-procedures] definiert -wurden. In diesen Fällen erzeugt @scheme[check-property] eine Fehlermeldung. +Fall, aber nicht für Signaturvariablen und Signaturen, die mit @scheme[predicate] +oder @scheme[define-record-procedures] definiert +wurden - wohl aber für Signaturen, die mit dem durch @scheme[define-record-procedures-parametric] definierten +Signaturkonstruktor erzeugt wurden. } @section{Parametrische Record-Typ-Definitionen} diff --git a/collects/lang/private/teach.rkt b/collects/lang/private/teach.rkt index 72b59545fd..736de15101 100644 --- a/collects/lang/private/teach.rkt +++ b/collects/lang/private/teach.rkt @@ -894,11 +894,18 @@ (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_ ...)) + (sig + (make-lazy-wrap-signature 'name_ #t + type-descriptor + raw-predicate + (list field_/no-loc ...) + #'name_))) + (let ((arbs (map signature-arbitrary sigs))) + (when (andmap values arbs) + (set-signature-arbitrary! sig + (apply arbitrary-record #,constructor-name arbs)))) + sig))) (values #,signature-name #,parametric-signature-name proc-name ...))) 'stepper-define-struct-hint