adjust parameter/c to use chaperone-procedure and fix a performance bug in contract-stronger

closes #3840

pkgs/racket-test/tests/racket/contract/equivalent.rkt

@@ -224,6 +224,9 @@
   (ctest #f contract-equivalent?
          (parameter/c (between/c 1 4) (between/c 0 5))
          (parameter/c (between/c 0 5) (between/c 1 4)))
+  (ctest #f contract-equivalent?
+         (parameter/c (between/c 0 5))
+         (parameter/c (between/c 0 5) (between/c 1 6)))
 
   (ctest #f contract-equivalent? (symbols 'x 'y) (symbols 'x 'y 'z))
   (ctest #f contract-equivalent? (symbols 'x 'y 'z) (symbols 'x 'y))

pkgs/racket-test/tests/racket/contract/parameter.rkt

@@ -2,7 +2,7 @@
 (require "test-util.rkt")
 
 (parameterize ([current-contract-namespace
-                (make-basic-contract-namespace)])
+                (make-basic-contract-namespace 'racket/contract/parametric)])
   
   (test/neg-blame
    'parameter/c1
@@ -47,4 +47,71 @@
    'parameter/c7
    '((contract (parameter/c integer? string?)
                (make-parameter 5 values)
-               'pos 'neg))))
+               'pos 'neg)))
+
+  (test/spec-passed/result
+   'parameter/c8
+   '(let ([p (make-parameter 1)])
+      (parameter-procedure=?
+       (contract (parameter/c integer?)
+                 p 'pos 'neg)
+       p))
+   #t)
+
+  (test/spec-passed/result
+   'parameter/c9
+   '(let ([p (make-parameter 1)])
+      (chaperone-of?
+       (contract (parameter/c integer?)
+                 p 'pos 'neg)
+       p))
+   #t)
+  
+  (test/spec-passed/result
+   'parameter/c10
+   '(let ([p (make-parameter 1)])
+      (parameter?
+       (contract (parameter/c integer?)
+                 p 'pos 'neg)))
+   #t)
+
+
+  (test/spec-passed/result
+   'parameter/c11
+   '(chaperone-contract?
+     (parameter/c integer?))
+   #t)
+
+  (test/spec-passed/result
+   'parameter/c12
+   '(chaperone-contract?
+     (parameter/c (-> integer? integer?)))
+   #t)
+  
+  (test/spec-passed/result
+   'parameter/c13
+   '(chaperone-contract?
+     (parameter/c (new-∀/c 'α)))
+   #f)
+
+
+  (test/spec-passed/result
+   'parameter/c14
+   '(chaperone-contract?
+     (parameter/c (new-∀/c 'α)
+                  integer?))
+   #f)
+
+  (test/spec-passed/result
+   'parameter/c15
+   '(chaperone-contract?
+     (parameter/c integer?
+                  (new-∀/c 'α)))
+   #f)
+
+  (test/spec-passed/result
+   'parameter/c16
+   '(chaperone-contract?
+     (parameter/c integer?
+                  (-> integer? integer?)))
+   #t))

pkgs/racket-test/tests/racket/contract/stronger.rkt

@@ -238,6 +238,7 @@
                                (parameter/c (between/c 1 4) (between/c 0 5)))
   (ctest #f trust/not-stronger? (parameter/c (between/c 1 4) (between/c 0 5))
                                (parameter/c (between/c 0 5) (between/c 1 4)))
+  (ctest #f trust/not-stronger? (parameter/c (between/c 0 5)) (parameter/c (between/c 0 5) (between/c 1 6)))
 
   (ctest #t trust/not-stronger? (symbols 'x 'y) (symbols 'x 'y 'z))
   (ctest #f trust/not-stronger? (symbols 'x 'y 'z) (symbols 'x 'y))

racket/collects/racket/contract/private/misc.rkt

@@ -468,25 +468,25 @@
   (case-lambda
     [(in-ctc)
      (define ctc (coerce-contract 'parameter/c in-ctc))
-     (make-parameter/c ctc ctc #f)]
+     (cond
+       [(chaperone-contract? ctc)
+        (chaperone-parameter/c ctc #f)]
+       [else
+        (impersonator-parameter/c ctc #f)])]
     [(in-ctc out-ctc)
-     (make-parameter/c (coerce-contract 'parameter/c in-ctc)
+     (define in (coerce-contract 'parameter/c in-ctc))
-                       (coerce-contract 'parameter/c out-ctc)
+     (define out (coerce-contract 'parameter/c out-ctc))
-                       #t)]))
+     (cond
+       [(and (chaperone-contract? in) (chaperone-contract? out))
+        (chaperone-parameter/c in out)]
+       [else
+        (impersonator-parameter/c in out)])]))
 
-;; in - negative contract
+(define (parameter/c-lnp ctc)
-;; out - positive contract
+  (define in-proc (get/build-late-neg-projection (base-parameter/c-in ctc)))
-;; both-supplied? - for backwards compat printing
+  (define out-proc (if (base-parameter/c-out/f ctc)
-(define-struct parameter/c (in out both-supplied?)
+                       (get/build-late-neg-projection (base-parameter/c-out/f ctc))
-  #:property prop:custom-write custom-write-property-proc
+                       in-proc))
-  #:omit-define-syntaxes
-  #:property prop:contract
-  (build-contract-property
-   #:trusted trust-me
-   #:late-neg-projection
-   (λ (ctc)
-     (define in-proc (get/build-late-neg-projection (parameter/c-in ctc)))
-     (define out-proc (get/build-late-neg-projection (parameter/c-out ctc)))
   (λ (blame)
     (define blame/c (blame-add-context blame "the parameter of"))
     (define in-proj (in-proc (blame-swap blame/c)))
@@ -495,47 +495,93 @@
       (define blame+neg-party (cons blame/c neg-party))
       (cond
         [(parameter? val)
-            (define (add-profiling f)
+         (chaperone-procedure
-              (λ (x)
+          val
+          (case-lambda
+            [(x)
              (with-contract-continuation-mark
                  blame+neg-party
-                 (f x neg-party))))
+               (in-proj x neg-party))]
-            ;; TODO this ought to have the `contracted` property, but it's not a chaperone...
+            [() (λ (res)
-            (make-derived-parameter
+                  (with-contract-continuation-mark
-             val
+                      blame+neg-party
-             (add-profiling in-proj)
+                    (out-proj res neg-party)))])
-             (add-profiling out-proj))]
+          impersonator-prop:contracted ctc
+          impersonator-prop:blame blame+neg-party)]
         [else
          (raise-blame-error blame #:missing-party neg-party
                             val '(expected "a parameter"))]))))
 
-   #:name
+(define (parameter/c-name ctc)
-   (λ (ctc) (apply build-compound-type-name
+  (define out (base-parameter/c-out/f ctc))
-                   `(parameter/c ,(parameter/c-in ctc)
+  (apply build-compound-type-name
-                                 ,@(if (parameter/c-both-supplied? ctc)
+         `(parameter/c ,(base-parameter/c-in ctc)
-                                       (list (parameter/c-out ctc))
+                       ,@(if out
+                             (list out)
                              (list)))))
-   #:first-order
+
-   (λ (ctc)
+(define (parameter/c-first-order ctc)
-      (let ([tst (contract-first-order (parameter/c-out ctc))])
+  (define tst (contract-first-order (base-parameter/c-out ctc)))
   (λ (x)
     (and (parameter? x)
-                (tst (x))))))
+         (tst (x)))))
 
-   #:stronger
+(define (parameter/c-stronger this that)
-   (λ (this that)
+  (and (base-parameter/c? that)
-      (and (parameter/c? that)
+       (cond
-           (and (contract-struct-stronger? (parameter/c-out this)
+         [(or (base-parameter/c-out/f this)
-                                           (parameter/c-out that))
+              (base-parameter/c-out/f that))
-                (contract-struct-stronger? (parameter/c-in that)
+          (and (contract-struct-stronger? (base-parameter/c-in that)
-                                           (parameter/c-in this)))))
+                                          (base-parameter/c-in this))
-   #:equivalent
+               (contract-struct-stronger? (base-parameter/c-out this)
-   (λ (this that)
+                                          (base-parameter/c-out that)))]
-      (and (parameter/c? that)
+         [else
-           (and (contract-struct-equivalent? (parameter/c-out this)
+          (contract-struct-equivalent? (base-parameter/c-in this)
-                                             (parameter/c-out that))
+                                       (base-parameter/c-in that))])))
-                (contract-struct-equivalent? (parameter/c-in that)
+
-                                             (parameter/c-in this)))))))
+(define (parameter/c-equivalent this that)
+  (and (base-parameter/c? that)
+       (cond
+         [(or (base-parameter/c-out/f this)
+              (base-parameter/c-out/f that))
+          (and (contract-struct-equivalent? (base-parameter/c-in this)
+                                            (base-parameter/c-in that))
+               (contract-struct-equivalent? (base-parameter/c-out this)
+                                            (base-parameter/c-out that)))]
+         [else
+          (contract-struct-equivalent? (base-parameter/c-in this)
+                                       (base-parameter/c-in that))])))
+  
+;; in - negative contract
+;; out - positive contract or #f
+;; out is #f if it was not supplied to `parameter/c`
+(struct base-parameter/c (in out/f)
+  #:property prop:custom-write custom-write-property-proc)
+
+(define (base-parameter/c-out b-p/c)
+  (or (base-parameter/c-out/f b-p/c)
+      (base-parameter/c-in b-p/c)))
+
+(struct impersonator-parameter/c base-parameter/c ()
+  #:omit-define-syntaxes
+  #:property prop:contract
+  (build-contract-property
+   #:trusted trust-me
+   #:late-neg-projection parameter/c-lnp
+   #:name parameter/c-name
+   #:first-order parameter/c-first-order
+   #:stronger parameter/c-stronger
+   #:equivalent parameter/c-equivalent))
+
+(struct chaperone-parameter/c base-parameter/c ()
+  #:property prop:chaperone-contract
+  (build-chaperone-contract-property
+   #:trusted trust-me
+   #:late-neg-projection parameter/c-lnp
+   #:name parameter/c-name
+   #:first-order parameter/c-first-order
+   #:stronger parameter/c-stronger
+   #:equivalent parameter/c-equivalent))
 
 (define (procedure-arity-includes-equivalent? this that)
   (and (procedure-arity-includes/c? that)