Push mixed' contracts down into lazy struct' contracts.

collects/deinprogramm/signature/signature.rkt

@@ -63,7 +63,7 @@
       => (lambda (name)
 	   (display "#<signature " port)
 	   (display name port)
-	   (display "#>" port)))
+	   (display ">" port)))
      (else
       (display "#<signature>" port)))))
 
@@ -138,14 +138,21 @@
 		   (force (signature-arbitrary-promise (force promise))))
 		 #:info-promise
 		 (delay
-		   (make-call-info (force proc-promise) (force args-promise)))
+		   (make-call-info promise (force proc-promise) (force args-promise)))
 		 #:=?-proc
 		 (lambda (this-info other-info)
 		   (and (call-info? other-info)
 			(eqv? (force proc-promise) (call-info-proc other-info))
 			(equal? (force args-promise) (call-info-args other-info))))))
 
-(define-struct call-info (proc args) #:transparent)
+(define-struct call-info (promise proc args) #:transparent)
+
+; klude to support mixed
+(define (real-signature-info sig)
+  (let ((raw-info (force (signature-info-promise sig))))
+    (if (call-info? raw-info)
+	(real-signature-info (force (call-info-promise raw-info)))
+	(force raw-info))))
 
 (define (make-property-signature name access signature syntax)
   (let ((enforce (signature-enforcer signature)))
@@ -239,38 +246,80 @@
 	#f)))
 
 (define (make-mixed-signature name alternative-signatures syntax)
-  (make-signature
-   name
-   (lambda (self obj)
-     (let loop ((alternative-signatures alternative-signatures))
-       (cond
-	((null? alternative-signatures)
-	 (signature-violation obj self #f #f)
-	 obj)
-	((eq? (car alternative-signatures) self)
-	 (raise
-	  (make-exn:fail:contract
-	   (string->immutable-string
-	    (if name
-		(format "rekursiver Vertrag: ~a" name)
-		"rekursiver Vertrag"))
-	   (current-continuation-marks))))
-	(else
-	 (check-signature (car alternative-signatures)
-			 obj
-			 values
-			 (lambda () (loop (cdr alternative-signatures))))))))
-   (delay syntax)
-   #:arbitrary-promise
-   (delay
-     (let ((arbitraries (map force (map signature-arbitrary-promise alternative-signatures))))
-       (if (andmap values arbitraries)
-	   (arbitrary-mixed 
-	    (map (lambda (sig arb)
-		   (cons (signature->predicate sig)
-			 arb))
-		 alternative-signatures arbitraries))
-	   #f)))))
+  (letrec ((alternative-signatures-promise 
+	    (delay
+	      (normalize-mixed-signatures mixed-signature alternative-signatures)))
+	   (mixed-signature
+	    (make-signature
+	     name
+	     (lambda (self obj)
+	       (let loop ((alternative-signatures (force alternative-signatures-promise)))
+		 (cond
+		  ((null? alternative-signatures)
+		   (signature-violation obj self #f #f)
+		   obj)
+		  ((eq? (car alternative-signatures) self)
+		   (raise
+		    (make-exn:fail:contract
+		     (string->immutable-string
+		      (if name
+			  (format "rekursiver Vertrag: ~a" name)
+			  "rekursiver Vertrag"))
+		     (current-continuation-marks))))
+		  (else
+		   (check-signature (car alternative-signatures)
+				    obj
+				    values
+				    (lambda () (loop (cdr alternative-signatures))))))))
+	     (delay syntax)
+	     #:info-promise
+	     (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)))
+	     #:=?-proc
+	     (lambda (this-info other-info)
+	       (and (mixed-info? other-info)
+		    (andmap signature=? 
+			    (mixed-info-signatures this-info) 
+			    (mixed-info-signatures other-info))))
+	     #:<=?-proc
+	     (lambda (this-info other-info)
+	       (and (mixed-info? other-info)
+		    (mixed-signature<=? (mixed-info-signatures this-info) 
+					(mixed-info-signatures other-info)))))))
+    mixed-signature))
+
+(define (mixed-signature<=? sigs1 sigs2)
+  (andmap (lambda (sig1)
+	    (ormap (lambda (sig2)
+		     (signature<=? sig1 sig2))
+		   sigs2))
+	  sigs1))
+
+; Flatten out mixed signatures, and fold in in the struct-wrap
+; signatures
+	
+(define (normalize-mixed-signatures mixed-signature sigs)
+  (fold-struct-wrap-signatures mixed-signature (flatten-mixed-signatures sigs)))
+
+(define (flatten-mixed-signatures sigs)
+  (apply append
+	 (map (lambda (sig)
+		(let ((info (force (signature-info-promise sig))))
+		  (if (mixed-info? info)
+		      (mixed-info-signatures info)
+		      (list sig))))
+	      sigs)))
+
+(define-struct mixed-info (signatures) #:transparent)
 
 (define (check-signature sig val success fail)
   ((let/ec exit
@@ -415,13 +464,36 @@
 ; The field accessed by ref-proc and set!-proc contains one of these:
 
 (define-struct lazy-wrap-log
-  ;; each contains a list of lists; each element is a list of field signatures
-  (not-checked checked)
-  #:transparent) 
+  ;; list of lazy-log-not-checked
+  (not-checked 
+  ;; list of lists of field signatures
+   checked)
+  #:transparent)
+
+; This situation makes trouble:
+; (make-mixed-signature (make-struct-wrap-signature ...)  (make-struct-wrap-signature ...) ...)
+
+; We need to push the `mixed' signature inside the struct-wrap
+; signature, which is why the struct-map signature has an implicit
+; `mixed'.
+; To this end, a `lazy-log-not-checked' object tracks a list of
+; `mixed' alternatives.  The `mixed-signature' field tracks from which
+; `mixed' contract the mixture has originally come from.  
+; (It may be #f, in which case the `field-signatures-list' is a one-element list.)
+(define-struct lazy-log-not-checked
+  (mixed-signature field-signatures-list)
+  #:transparent)
 
 (define (make-struct-wrap-signature name type-descriptor field-signatures syntax)
+  (really-make-struct-wrap-signature name type-descriptor #f (list field-signatures) syntax))
+
+; The lists of signatures in `field-signatures-list' form an implicit mixed signature.
+(define (really-make-struct-wrap-signature name type-descriptor 
+					   mixed-signature field-signatures-list
+					   syntax)
   (let ((lazy-wrap-info (lazy-wrap-ref type-descriptor))
-	(struct-wrap-info (make-struct-wrap-info type-descriptor field-signatures))
+	(not-checked (make-lazy-log-not-checked mixed-signature field-signatures-list))
+	(struct-wrap-info (make-struct-wrap-info type-descriptor field-signatures-list))
 	(predicate (lambda (thing)
 		     (and (struct? thing)
 			  (let-values (((thing-descriptor _) (struct-info thing)))
@@ -432,7 +504,7 @@
 	  (wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info)))
     (make-signature
      name
-     (lambda (self thing)
+      (lambda (self thing)
 
        (if (not (predicate thing))
 	   (signature-violation thing self #f #f)
@@ -440,15 +512,21 @@
 	     (cond
 	      ((not log)
 	       (wrap-set! thing
-			  (make-lazy-wrap-log (list field-signatures) '())))
-	      ((not (let ((check (lambda (wrap-field-signatures)
-				   (andmap signature<=?
-					   wrap-field-signatures
-					   field-signatures))))
-		      (or (ormap check (lazy-wrap-log-not-checked log))
+			  (make-lazy-wrap-log (list not-checked) '())))
+	      ((not (let ()
+		      (define (<=? sigs1 sigs2)
+			(andmap signature<=? sigs1 sigs2))
+		      (define (check wrap-field-signatures)
+			(ormap (lambda (field-signatures)
+				 (<=? wrap-field-signatures field-signatures))
+			       field-signatures-list))
+		      (or (ormap (lambda (wrap-not-checked)
+				   (andmap check 
+					   (lazy-log-not-checked-field-signatures-list wrap-not-checked)))
+				 (lazy-wrap-log-not-checked log))
 			  (ormap check (lazy-wrap-log-checked log)))))
 	       (wrap-set! thing
-			  (make-lazy-wrap-log (cons field-signatures (lazy-wrap-log-not-checked log))
+			  (make-lazy-wrap-log (cons not-checked (lazy-wrap-log-not-checked log))
 					      (lazy-wrap-log-checked log)))))))
        
        thing)
@@ -458,21 +536,25 @@
      #:=?-proc
      (lambda (this-info other-info)
        (and (struct-wrap-info? other-info)
-	    (struct-wrap-info-field-signatures other-info)
+	    (struct-wrap-info-field-signatures-list other-info)
 	    (eq? type-descriptor (struct-wrap-info-descriptor other-info))
-	    (andmap signature=?
-		    field-signatures
-		    (struct-wrap-info-field-signatures other-info))))
+	    (andmap (lambda (this-field-signatures)
+		      (andmap (lambda (other-field-signatures)
+				(andmap signature=? this-field-signatures other-field-signatures))
+			      (struct-wrap-info-field-signatures-list other-info)))
+		    (struct-wrap-info-field-signatures-list this-info))))
      #:<=?-proc
      (lambda (this-info other-info)
        (and (struct-wrap-info? other-info)
-	    (struct-wrap-info-field-signatures other-info) 
+	    (struct-wrap-info-field-signatures-list other-info) 
 	    (eq? type-descriptor (struct-wrap-info-descriptor other-info))
-	    (andmap signature<=?
-		    field-signatures
-		    (struct-wrap-info-field-signatures other-info))))))))
+	    (andmap (lambda (this-field-signatures)
+		      (ormap (lambda (other-field-signatures)
+			       (andmap signature<=? this-field-signatures other-field-signatures))
+			      (struct-wrap-info-field-signatures-list other-info)))
+		    (struct-wrap-info-field-signatures-list this-info))))))))
 
-(define-struct struct-wrap-info (descriptor field-signatures))
+(define-struct struct-wrap-info (descriptor field-signatures-list) #:transparent)
 
 (define (check-struct-wraps! thing)
   (let-values (((descriptor skipped?) (struct-info thing)))
@@ -489,18 +571,76 @@
 	    (let loop ((field-vals (map (lambda (raw-accessor)
 					  (raw-accessor thing))
 					raw-accessors))
-		       (field-signatures-list (lazy-wrap-log-not-checked log)))
-	      (if (null? field-signatures-list)
+		       (now-checked '())
+		       (not-checkeds (lazy-wrap-log-not-checked log)))
+	      (if (null? not-checkeds)
 		  (begin
 		    (for-each (lambda (raw-mutator field-val)
 				(raw-mutator thing field-val))
 			      raw-mutators field-vals)
 		    (wrap-set! thing
 			       (make-lazy-wrap-log '()
-						   (append (lazy-wrap-log-not-checked log)
+						   (append now-checked
 							   (lazy-wrap-log-checked log)))))
-		  (loop (map apply-signature (car field-signatures-list) field-vals)
-			(cdr field-signatures-list))))))))))
+		  (let ((not-checked (car not-checkeds)))
+		    (let ((field-signatures-list (lazy-log-not-checked-field-signatures-list not-checked))
+			  (mixed-signature (lazy-log-not-checked-mixed-signature not-checked)))
+		    (if (not mixed-signature) ; one-element list
+			(loop (map apply-signature (car field-signatures-list) field-vals)
+			      (cons (car field-signatures-list) now-checked)
+			      (cdr not-checkeds))
+			(let inner ((field-signatures-list field-signatures-list)) ; implicit mixed
+			  (if (null? field-signatures-list)
+			      (signature-violation thing mixed-signature #f #f)
+			      (let map ((sigs (car field-signatures-list))
+					(field-vals field-vals)
+					(new-field-vals '()))
+				(if (null? sigs)
+				    (loop (reverse new-field-vals)
+					  (cons (car field-signatures-list) now-checked)
+					  (cdr not-checkeds))
+				    (check-signature (car sigs)
+						     (car field-vals)
+						     (lambda (new-val)
+						       (map (cdr sigs)
+							    (cdr field-vals)
+							    (cons new-val new-field-vals)))
+						     (lambda ()
+						       (inner (cdr field-signatures-list)))))))))))))))))))
+
+; pushes down mixed contracts
+(define (fold-struct-wrap-signatures mixed-signature sigs)
+  (let ((struct-wrap-sigs (make-hasheq))) ; maps a type descriptor to signatures
+
+    (define (push-down-struct-wrap-sigs)
+      (hash-map struct-wrap-sigs
+		(lambda (type-desc signatures)
+		  (really-make-struct-wrap-signature 
+		   (signature-name (car signatures)) type-desc 
+		   mixed-signature
+		   (apply append
+			  (map (lambda (sig)
+				 (struct-wrap-info-field-signatures-list (real-signature-info sig)))
+			       signatures))
+		   (signature-syntax (car signatures))))))
+  
+    (let loop ((sigs sigs)
+	       (vanilla-sigs '()))
+      (if (null? sigs)
+	  (append (push-down-struct-wrap-sigs)
+		  (reverse vanilla-sigs))
+	  (let* ((sig (car sigs))
+		 (info (real-signature-info sig)))
+	    (if (struct-wrap-info? info)
+		(let ((type-desc (struct-wrap-info-descriptor info)))
+		  (hash-update! struct-wrap-sigs
+				type-desc
+				(lambda (old)
+				  (cons sig old))
+				(lambda ()
+				  (list sig)))
+		  (loop (cdr sigs) vanilla-sigs))
+		(loop (cdr sigs) (cons sig vanilla-sigs))))))))
 
 ; like apply-signature, but can track more precise blame into the signature itself
 (define-syntax apply-signature/blame

collects/tests/deinprogramm/signature.rkt

@@ -348,6 +348,17 @@
 	(let ((len1 (list-length l1)))
 	  (check-equal? count 10)))))
 
+   (test-case
+    "mixed wrap"
+    (define-record-procedures-parametric pare pare-of raw-kons pare? (kar kdr))
+    (define sig1 (signature (pare-of integer boolean)))
+    (define sig2 (signature (pare-of boolean integer)))
+    (define sig (signature (mixed sig1 sig2)))
+    (define/signature x sig (raw-kons #t 15))
+    (define/signature y sig (raw-kons #t #t))
+    (check-equal? (kar x) #t)
+    (check-equal? (say-no (kar y)) 'no))
+
    (test-case
     "wrap equality"
     (define-record-procedures-parametric pare pare-of raw-kons pare? (kar kdr))