more complete function application

i.e. when applying a case->, the result is the intersection of
each applicable range.

Here are some quickly gathered performance results from this change:

Compile time ratio (old time / new time):
schml-specify-rep: 0.99 (i.e. slower, 8.63s (σ 0.09) to 8.72s (σ 0.05))
schml-interp-casts-help: 1.01 (i.e. faster, 20.05s (σ 0.24) to 19.77s (σ 0.01))
parser: 0.95 (i.e. slower, 2.22s (σ 0.05) to 2.33s (σ 0.09))
old-metrics: 0.96 (i.e. slower, 2.68s (σ 0.04) to 2.78s (σ 0.09))
new-metrics: 0.98 (i.e. slower, 3.61s (σ 0.02) to 3.7s (σ 0.08))
math-flonum: 0.98 (i.e. slower, 3.76s (σ 0.02) to 3.83s (σ 0.08))
fsm: 0.94 (i.e. slower, 4.91s (σ 0.09) to 5.22s (σ 0.19))
forth: 0.97 (i.e. slower, 4.87s (σ 0.18) to 5.01s (σ 0.01))
dungeon: 0.95 (i.e. slower, 8.64s (σ 0.11) to 9.11s (σ 0.18))
bernoulli: 0.95 (i.e. slower, 3.95s (σ 0.04) to 4.16s (σ 0.09))
acquire: 0.96 (i.e. slower, 15.53s (σ 0.23) to 16.2s (σ 0.08))

And for the math library, compile time increased from 2m28.281s
to 2m40.492s.

Note that some primtives (i.e. like those which operate on the
numeric tower) currently have quite verbose function types which
can be greatly simplified after this change is adopted.

Author: pnwamk

typed-racket-lib/typed-racket/base-env/base-env-numeric.rkt

@@ -1498,7 +1498,7 @@
              ;; no positive / negative cases, possible underflow
              (-NonNegReal . -> . -NonNegSingleFlonum)
              (-NonPosReal . -> . -NonPosSingleFlonum)
-             (-Real . -> . -SingleFlonumZero))]
+             (-Real . -> . -SingleFlonum))]
 [real->double-flonum
  (from-cases (map unop all-flonum-types)
              (-SingleFlonumPosZero . -> . -FlonumPosZero)

typed-racket-lib/typed-racket/env/lexical-env.rkt

@@ -33,7 +33,7 @@
  [lookup-obj-type/lexical ((Object?) (env? #:fail (or/c #f Type? (-> any/c (or/c Type? #f))))
                                      . ->* .
                                      (or/c Type? #f))]
- [lookup-alias/lexical ((identifier?) (env?) . ->* . (or/c Path? Empty?))])
+ [lookup-alias/lexical ((identifier?) (env?) . ->* . OptObject?)])
 
 ;; used at the top level
 (define (add-props-to-current-lexical! ps)

typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt

@@ -136,7 +136,7 @@
     [stx:exn-body^
      (set! body-results (tc-expr/check #'stx expected))])
   (define handler-results (get-handler-results))
-  (merge-tc-results (cons body-results handler-results)))
+  (union-tc-results (cons body-results handler-results)))
 
 ;; typecheck the expansion of a with-handlers form
 ;; syntax -> void

typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt

@@ -15,11 +15,14 @@
 (provide/cond-contract
   [tc/funapp1
     ((syntax? stx-list? Arrow? (listof tc-results/c) (or/c #f tc-results/c))
-     (#:check boolean?)
+     (#:check boolean? #:tooltip? boolean?)
      . ->* . full-tc-results/c)])
-(define (tc/funapp1 f-stx args-stx ftype0 arg-ress expected #:check [check? #t])
+(define (tc/funapp1 f-stx args-stx ftype0 arg-ress expected
+                    #:check [check? #t]
+                    #:tooltip? [tooltip? #t])
   ;; update tooltip-table with inferred function type
-  (add-typeof-expr f-stx (ret (make-Fun (list ftype0))))
+  (when tooltip?
+    (add-typeof-expr f-stx (ret (make-Fun (list ftype0)))))
   (match* (ftype0 arg-ress)
     ;; we check that all kw args are optional
     [((Arrow: dom rst (list (Keyword: _ _ #f) ...) rng)

typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt

@@ -6,7 +6,7 @@
          (utils tc-utils identifier)
          (env tvar-env lexical-env)
          (for-syntax syntax/parse racket/base)
-         (types utils subtype resolve abbrev
+         (types utils subtype resolve abbrev type-table
                 substitute classes prop-ops)
          (typecheck tc-metafunctions tc-app-helper tc-subst tc-envops
                     check-below)
@@ -115,17 +115,14 @@
        ;; check there are no RestDots
        #:when (not (for/or ([a (in-list arrows)])
                      (RestDots? (Arrow-rst a))))
-       (cond
-         ;; find the first function where the argument types match
-         [(ormap (match-lambda
-                   [(and a (Arrow: dom rst _ _))
-                    (and (subtypes/varargs argtys dom rst) a)])
-                 arrows)
-          => (λ (a)
-               ;; then typecheck here -- we call the separate function so that we get
-               ;; the appropriate props/objects
-               (tc/funapp1 f-stx args-stx a args-res expected #:check #f))]
-         [else
+       (define applicable-arrows
+         (filter (match-lambda
+                   [(Arrow: dom rst _ _)
+                    (subtypes/varargs argtys dom rst)])
+                 arrows))
+       
+       (match applicable-arrows
+         [(list)
           ;; if nothing matched, error
           (match arrows
             [(list (Arrow: doms rsts _ rngs) ...)
@@ -135,7 +132,30 @@
               #:msg-thunk (lambda (dom)
                             (string-append
                              "No function domains matched in function application:\n"
-                             dom)))])])]
+                             dom)))])]
+         [(list a) (tc/funapp1 f-stx args-stx a args-res expected #:check #f)]
+         [_
+          ;; call a separate function so that we get
+          ;; the appropriate props/objects
+          (define app-result
+            (intersect-tc-results
+             (for/list ([a (in-list applicable-arrows)])
+               (tc/funapp1 f-stx args-stx a args-res expected
+                           #:check #f
+                           #:tooltip? #f))))
+          (define applicable-domain
+            ;; gather and intersect applicable domains to report to user
+            ;; generally what class of inputs produces the resulting output
+            (for/fold ([domtys (build-list (length argtys) (λ (_) Univ))])
+                      ([a (in-list applicable-arrows)])
+              (match a
+                [(Arrow: dom rst _ _) (for/list ([domty (in-list domtys)]
+                                                 [idx (in-naturals)])
+                                        (intersect domty (dom+rst-ref dom rst idx)))])))
+          (add-typeof-expr
+           f-stx
+           (ret (make-Fun (list (-Arrow applicable-domain (tc-results->values app-result))))))
+          app-result])]
       ;; any kind of dotted polymorphic function without mandatory keyword args
       [(PolyDots: (list fixed-vars ... dotted-var)
                   (Fun: arrows))
@@ -308,7 +328,7 @@
       ;; a union of functions can be applied if we can apply all of the elements
       [(Union: (? Bottom?) ts) #:when (for/and ([t (in-list ts)])
                                         (subtype t top-func))
-       (merge-tc-results
+       (union-tc-results
         (for/list ([fty (in-list ts)])
           (tc/funapp f-stx args-stx fty args-res expected)))]
       ;; bottom or error type is a perfectly good fcn type

typed-racket-lib/typed-racket/typecheck/tc-if.rkt

@@ -30,7 +30,7 @@
        ;; if there was not any expected results, then merge the 'then'
        ;; and 'else' results so we propogate the correct info upwards
        [(or #f (tc-any-results: #f))
-        (merge-tc-results (list thn-res els-res))]
+        (union-tc-results (list thn-res els-res))]
        ;; otherwise, the subcomponents have already been checked and
        ;; we just return the expected result 'fixed' to replace any
        ;; missing fields (i.e. #f props or objects)

typed-racket-lib/typed-racket/typecheck/tc-metafunctions.rkt

@@ -5,14 +5,16 @@
          racket/match racket/list
          (except-in (types abbrev utils prop-ops)
                     -> ->* one-of/c)
+         (only-in (infer infer) intersect)
          (rep type-rep prop-rep object-rep values-rep rep-utils)
          (typecheck tc-subst)
          (logic ineq)
          (contract-req))
 
 (provide abstract-results
          combine-props
-         merge-tc-results
+         union-tc-results
+         intersect-tc-results
          tc-results->values
          erase-existentials)
 
@@ -145,7 +147,7 @@
               (-or p+ p-)])
            tcrs))]))
 
-(define (merge-tc-results results [ignore-propositions? #f])
+(define (union-tc-results results [ignore-propositions? #f])
   (define/match (merge-tc-result r1 r2)
     [((tc-result: t1 (and ps1 (PropSet: p1+ p1-)) o1)
       (tc-result: t2 (PropSet: p2+ p2-) o2))
@@ -165,13 +167,13 @@
      (make-RestDots (Un t1 t2) dbound)])
 
 
-  (define/match (merge-two-results res1 res2)
+  (define/match (union-two-results res1 res2)
     [((tc-result1: (== -Bottom)) res2) res2]
     [(res1 (tc-result1: (== -Bottom))) res1]
-    [((tc-any-results: f1) res2)
-     (-tc-any-results (-or f1 (unconditional-prop res2)))]
-    [(res1 (tc-any-results: f2))
-     (-tc-any-results (-or (unconditional-prop res1) f2))]
+    [((tc-any-results: p1) res2)
+     (-tc-any-results (-or p1 (unconditional-prop res2)))]
+    [(res1 (tc-any-results: p2))
+     (-tc-any-results (-or (unconditional-prop res1) p2))]
     [((tc-results: results1 dty1)
       (tc-results: results2 dty2))
      ;; if we have the same number of values in both cases
@@ -188,7 +190,55 @@
                            (format "~a and ~a." (length results2) (length results1))))])])
 
   (for/fold ([res (ret -Bottom)]) ([res2 (in-list results)])
-    (merge-two-results res res2)))
+    (union-two-results res res2)))
+
+(define (intersect-tc-results results)
+  (define/match (merge-tc-result r1 r2)
+    [((tc-result: t1 (PropSet: p1+ p1-) o1)
+      (tc-result: t2 (PropSet: p2+ p2-) o2))
+     (-tc-result (intersect t1 t2)
+                 (-PS (-and p1+ p2+) (-and p1- p2-))
+                 (match* (o1 o2)
+                   [(o o) o]
+                   [((Empty:) _) o2]
+                   [(_ (Empty:)) o1]
+                   [(_ _) -empty-obj]))])
+
+  (define/match (same-dty? r1 r2)
+    [(#f #f) #t]
+    [((RestDots: t1 dbound) (RestDots: t2 dbound)) #t]
+    [(_ _) #f])
+  (define/match (merge-dty r1 r2)
+    [(#f #f) #f]
+    [((RestDots: t1 dbound) (RestDots: t2 dbound))
+     (make-RestDots (intersect t1 t2) dbound)])
+
+
+  (define/match (intersect-two-results res1 res2)
+    [((tc-result1: (== -Bottom)) res2) (ret -Bottom)]
+    [(res1 (tc-result1: (== -Bottom))) (ret -Bottom)]
+    [((tc-any-results: p1) res2) (add-unconditional-prop res2 p1)]
+    [(res1 (tc-any-results: p2)) (add-unconditional-prop res1 p2)]
+    [((tc-results: results1 dty1) (tc-results: results2 dty2))
+     ;; if we have the same number of values in both cases
+     (cond
+       [(and (= (length results1) (length results2))
+             (same-dty? dty1 dty2))
+        (-tc-results (map merge-tc-result results1 results2)
+                     (merge-dty dty1 dty2))]
+       ;; otherwise, error
+       [else
+        (tc-error/expr "Expected the same number of values, but got ~a"
+                       (if (< (length results1) (length results2))
+                           (format "~a and ~a." (length results1) (length results2))
+                           (format "~a and ~a." (length results2) (length results1))))])])
+
+  (match results
+    [(list r) r]
+    [(cons r rs)
+     (for/fold ([r-acc r])
+               ([r (in-list rs)])
+       (intersect-two-results r-acc r))]))
 
 
 (define (erase-existentials rep)

typed-racket-lib/typed-racket/typecheck/tc-send.rkt

@@ -42,7 +42,7 @@
                      rcvr-type)])]
       ;; union of objects, check pointwise and union the results
       [(Union: (? Bottom?) objs) #:when (andmap Instance? objs)
-       (merge-tc-results (map do-check objs))]
+       (union-tc-results (map do-check objs))]
       [_ (tc-error/expr/fields
           "send: type mismatch"
           "expected" "an object"

typed-racket-lib/typed-racket/types/type-table.rkt

@@ -67,13 +67,13 @@
               ;; the car should be the latest stx for the location
               (if (equal? e (car seen))
                   ;; combine types seen at the latest
-                  (tooltip seen (merge-tc-results (list t results) #t))
+                  (tooltip seen (union-tc-results (list t results) #t))
                   old)
               (tooltip (cons e seen) t))]))
      #f))
   (hash-update! type-table e
                 (λ (prev) (cond
-                            [prev (merge-tc-results (list t prev) #t)]
+                            [prev (union-tc-results (list t prev) #t)]
                             [else t]))
                 #f))
 

typed-racket-test/unit-tests/metafunction-tests.rkt

@@ -75,33 +75,33 @@
        #t)
     )
 
-    (test-suite "merge-tc-results"
+    (test-suite "union-tc-results"
       (check-equal?
-        (merge-tc-results (list))
+        (union-tc-results (list))
         (ret -Bottom))
       (check-equal?
-        (merge-tc-results (list (ret Univ)))
+        (union-tc-results (list (ret Univ)))
         (ret Univ))
       (check-equal?
-        (merge-tc-results (list (ret Univ -tt-propset (make-Path null #'x))))
+        (union-tc-results (list (ret Univ -tt-propset (make-Path null #'x))))
         (ret Univ -tt-propset (make-Path null #'x)))
       (check-equal?
-        (merge-tc-results (list (ret -Bottom) (ret -Symbol -tt-propset (make-Path null #'x))))
+        (union-tc-results (list (ret -Bottom) (ret -Symbol -tt-propset (make-Path null #'x))))
         (ret -Symbol -tt-propset (make-Path null #'x)))
       (check-equal?
-        (merge-tc-results (list (ret -String) (ret -Symbol)))
+        (union-tc-results (list (ret -String) (ret -Symbol)))
         (ret (Un -Symbol -String)))
       (check-equal?
-        (merge-tc-results (list (ret -String -true-propset) (ret -Symbol -true-propset)))
+        (union-tc-results (list (ret -String -true-propset) (ret -Symbol -true-propset)))
         (ret (Un -Symbol -String) -true-propset))
       (check-equal?
-        (merge-tc-results (list (ret (-val #f) -false-propset) (ret -Symbol -true-propset)))
+        (union-tc-results (list (ret (-val #f) -false-propset) (ret -Symbol -true-propset)))
         (ret (Un -Symbol (-val #f)) -tt-propset))
       (check-equal?
-        (merge-tc-results (list (ret (list (-val 0) (-val 1))) (ret (list (-val 1) (-val 2)))))
+        (union-tc-results (list (ret (list (-val 0) (-val 1))) (ret (list (-val 1) (-val 2)))))
         (ret (list (Un (-val 0) (-val 1)) (Un (-val 1) (-val 2)))))
       (check-equal?
-        (merge-tc-results (list (ret null null null -Symbol 'x) (ret null null null -String 'x)))
+        (union-tc-results (list (ret null null null -Symbol 'x) (ret null null null -String 'x)))
         (ret null null null (Un -Symbol -String) 'x))
     )