Create arbitraties off parametric struct/record signature constructors.

This enables QuickCheck value generations for structs/records.

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)

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

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

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

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}

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