Make optimize for static contracts have saner interface.

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt

@@ -156,7 +156,8 @@
     (instantiate
       (optimize
         (type->static-contract ty #:typed-side typed-side fail)
-        (if typed-side 'covariant 'contravariant))
+        #:trusted-positive typed-side
+        #:trusted-negative (not typed-side))
       fail
       kind)))
 

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt

@@ -105,9 +105,11 @@
                       (merge-restricts* 'kind.category-stx (sc.->restricts v recur)))]
                 #:methods gen:equal+hash
                   [(define (equal-proc a b recur)
+                     (and (recur (length (combinator-args a))
+                                 (length (combinator-args b)))
                           (for/and ([sub-a (in-list (combinator-args a))]
                                     [sub-b (in-list (combinator-args b))])
-                       (recur sub-a sub-b)))
+                            (recur sub-a sub-b))))
                    (define (hash-proc v recur)
                      (+ (recur 'sc.name)
                         (for/sum ((sub (in-list (combinator-args v))))

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt

@@ -1,7 +1,7 @@
 #lang racket/base
 
-;; Functionalityt otoptimize a static contract to provide faster checking.
+;; Functionality to optimize a static contract to provide faster checking.
-;; Also supports droping one side's obligations.
+;; Also supports droping checks on either side.
 
 (require "combinators.rkt"
          "structures.rkt"
@@ -14,10 +14,13 @@
 
 (provide
   (contract-out
-    [optimize (static-contract? (or/c 'covariant 'contravariant 'invariant ) . -> . static-contract?)]))
+    [optimize ((static-contract?) (#:trusted-positive boolean? #:trusted-negative boolean?)
+               . ->* . static-contract?)]))
 
-(define (none/sc-reduce sc)
+;; Reduce a static contract to a smaller simpler one that protects in the same way
+(define (reduce sc)
   (match sc
+    ;; none/sc cases
     [(listof/sc: (none/sc:)) empty-list/sc]
     [(list/sc: sc1 ... (none/sc:) sc2 ...) none/sc]
     [(vectorof/sc: (none/sc:)) empty-vector/sc]
@@ -28,11 +31,8 @@
     [(promise/sc: (none/sc:)) none/sc]
     [(hash/sc: (none/sc:) value/sc) empty-hash/sc]
     [(hash/sc: key/sc (none/sc:)) empty-hash/sc]
-    [else sc]))
 
-
+    ;; any/sc cases
-(define (any/sc-reduce sc)
-  (match sc
     [(listof/sc: (any/sc:)) list?/sc]
     [(list/sc: (and scs (any/sc:)) ...) (list-length/sc (length scs))]
     [(vectorof/sc: (any/sc:)) vector?/sc]
@@ -42,88 +42,80 @@
     [(syntax/sc: (any/sc:)) syntax?/sc]
     [(promise/sc: (any/sc:)) promise?/sc]
     [(hash/sc: (any/sc:) (any/sc:)) hash?/sc]
+
+    ;; or/sc cases
+    [(or/sc: scs ...)
+     (match scs
+      [(list) none/sc]
+      [(list sc) sc]
+      [(? (λ (l) (member any/sc l))) any/sc]
+      [(? (λ (l) (member none/sc l)))
+       (apply or/sc (remove* (list none/sc) scs))]
+      [else sc])]
+
+    ;; and/sc cases
+    [(and/sc: scs ...)
+     (match scs
+      [(list) any/sc]
+      [(list sc) sc]
+      [(? (λ (l) (member none/sc l))) none/sc]
+      [(? (λ (l) (member any/sc l)))
+       (apply and/sc (remove* (list any/sc) scs))]
+      [else sc])]
+
+
+
     [else sc]))
 
 
-(define (covariant-any/sc-reduce sc)
+;; Reduce a static contract assuming that we trusted the current positive side
+(define (trusted-side-reduce sc)
   (match sc
     [(->/sc: mand-args opt-args mand-kw-args opt-kw-args rest-arg (list (any/sc:) ...))
      (function/sc mand-args opt-args mand-kw-args opt-kw-args rest-arg #f)]
     [(arr/sc: args rest (list (any/sc:) ...))
      (arr/sc args rest #f)]
-    [else sc]))
-
-(define (covariant-none/sc-reduce sc)
-  (match sc
     [(none/sc:) any/sc]
-    [else sc]))
-
-(define (or/sc-reduce sc)
-  (match sc
-    [(or/sc:) none/sc]
-    [(or/sc: sc) sc]
-    [(or/sc: sc1 ... (any/sc:) sc2 ...)
-     any/sc]
-    [(or/sc: sc1 ... (none/sc:) sc2 ...)
-     (or/sc-reduce (apply or/sc (append sc1 sc2)))]
-    [else sc]))
-
-(define (and/sc-reduce sc)
-  (match sc
-    [(and/sc:) any/sc]
-    [(and/sc: sc) sc]
-    [(and/sc: sc1 ... (none/sc:) sc2 ...)
-     none/sc]
-    [(and/sc: sc1 ... (any/sc:) sc2 ...)
-     (and/sc-reduce (apply and/sc (append sc1 sc2)))]
-    [else sc]))
-
-
-
-(define (covariant-flat-reduce sc)
-  (match sc
     [(? flat/sc?) any/sc]
-    [(none/sc:) any/sc]
+    [else sc]))
-    [sc sc]))
 
-(define (invert-variance v)
+
+
+(define (invert-side v)
   (case v
-    [(covariant) 'contravariant]
+    [(positive) 'negative]
-    [(contravariant) 'covariant]
+    [(negative) 'positive]
-    [(invariant) 'invariant]))
+    [(both) 'both]))
 
-(define (combine-variance var1 var2)
+(define (combine-variance side var)
-  (case var1
+  (case var
-    [(covariant) var2]
+    [(covariant) side]
-    [(contravariant) (invert-variance var2)]
+    [(contravariant) (invert-side side)]
-    [(invariant) 'invariant]))
+    [(invariant) 'both]))
 
-;; If the variance is 'covariant, drops the parts ensuring that server behaves
+;; If we trust a specific side then we drop all contracts protecting that side.
-;; If the variance is 'contrvariant, drops the parts ensuring that client behaves
+(define (optimize sc #:trusted-positive [trusted-positive #f] #:trusted-negative [trusted-negative #f])
-;; If the variance is 'invariant, only optimizes the contract.
+  ;; single-step: reduce and trusted-side-reduce if appropriate
-(define (optimize sc variance)
+  (define (single-step sc side)
-  (define (single-step sc variance)
+    (define trusted
-    (define ((maybe/co reduce) sc)
+      (case side
-      (case variance
+        [(positive) trusted-positive]
-        [(covariant) (reduce sc)]
+        [(negative) trusted-negative]
-        [(contravariant invariant) sc]
+        [(both) (and trusted-positive trusted-negative)]))
-        [else (error 'maybe/co "Bad variance ~a" variance)]))
 
-    ((compose
+    (reduce
-       (maybe/co covariant-flat-reduce)
+      (if trusted
-       (maybe/co covariant-any/sc-reduce)
+          (trusted-side-reduce sc)
-       (maybe/co covariant-none/sc-reduce)
+          sc)))
-       and/sc-reduce
-       or/sc-reduce
-       none/sc-reduce
-       any/sc-reduce)
-     sc))
 
+  ;; full-pass: single-step at every static contract subpart
   (define (full-pass sc)
-    (define ((recur current-variance) sc variance)
+    (define ((recur side) sc variance)
-      (define new-variance (combine-variance current-variance variance))
+      (define new-side (combine-variance side variance))
-      (single-step (sc-map sc (recur new-variance)) new-variance))
+      (single-step (sc-map sc (recur new-side)) new-side))
-    ((recur variance) sc 'covariant))
+    ((recur 'positive) sc 'covariant))
+
+  ;; Do full passes until we reach a fix point
   (let loop ((sc sc))
     (define new-sc (full-pass sc))
     (if (equal? sc new-sc)

pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt

@@ -16,7 +16,11 @@
       (list (make-check-info 'original argument)
             (make-check-expected expected))
       (lambda ()
-        (let ([opt (optimize argument variance)])
+        (define trusted-positive (equal? variance 'covariant))
+        (define trusted-negative (equal? variance 'contravariant))
+        (let ([opt (optimize argument
+                     #:trusted-positive trusted-positive
+                     #:trusted-negative trusted-negative)])
           (with-check-info* (list (make-check-actual opt))
             (lambda ()
               (unless (equal? opt expected)