Resolve callable foreign unions safely

Author: tompassarelli

beagle-lib/private/check.rkt

@@ -7140,7 +7140,7 @@
           inferred-call-type]
          [else raw-type]))
      (cond
-       [(type-foreign? fn-type)
+       [(foreign-call-contract-v1? fn-type)
         (define arguments (call-form-args e))
         (define-values (argument-evidence argument-types)
           (infer-foreign-arguments arguments env))
@@ -7310,7 +7310,7 @@
 
 (define (infer-jst-call-contract raw-contract selector receiver-type args env e)
   (cond
-    [(type-foreign? raw-contract)
+    [(foreign-call-contract-v1? raw-contract)
      (define-values (argument-evidence argument-types)
        (infer-foreign-arguments args env))
      (foreign-call-v1 raw-contract argument-evidence argument-types)]

beagle-lib/private/foreign-interface-v1.rkt

@@ -4128,8 +4128,30 @@
    (hash-ref (car selected) 'return)
    (cdr selected)))
 
+(define (foreign-call-contract-v1? type)
+  (cond
+    [(type-foreign? type) #t]
+    [(type-union? type)
+     (and
+      (pair? (type-union-alts type))
+      (andmap foreign-call-contract-v1? (type-union-alts type)))]
+    [else #f]))
+
+(define (foreign-call-alternatives type)
+  (if (type-union? type)
+      (append-map foreign-call-alternatives (type-union-alts type))
+      (list type)))
+
 (define (foreign-call-v1 type expressions actuals)
-  (foreign-invoke-v1 type expressions actuals 'call))
+  (unless (foreign-call-contract-v1? type)
+    (raise-argument-error 'foreign-call-v1 "foreign call contract" type))
+  (define results
+    (for/list ([alternative (in-list (foreign-call-alternatives type))])
+      (foreign-invoke-v1 alternative expressions actuals 'call)))
+  (define unique-results (remove-duplicates results equal?))
+  (if (null? (cdr unique-results))
+      (car unique-results)
+      (type-union unique-results)))
 
 (define (foreign-construct-v1 type expressions actuals)
   (foreign-invoke-v1 type expressions actuals 'construct))
@@ -4451,6 +4473,7 @@
  foreign-type-compatible-v1
  foreign-ambient-value-types-v1
  foreign-native-member-type-v1
+ foreign-call-contract-v1?
  foreign-call-v1
  foreign-construct-v1
  foreign-member-type-v1

beagle-test/tests/foreign-interface-v1-checker.rkt

@@ -559,6 +559,53 @@
    (foreign-call-v1 (foreign-type "n:overloaded") (list 7) (list INT))
    FLOAT))
 
+(test-case "callable foreign unions require every alternative to accept the call"
+  (define interface
+    (make-interface
+     (list
+      (wire-export "LeftCallable" "callable:left")
+      (wire-export "NumericCallable" "callable:numeric")
+      (wire-export "RightCallable" "callable:right"))
+     (list
+      (wire-function
+       "callable:left"
+       (wire-signature
+        (list (wire-parameter "value" "callable:string"))
+        "callable:string"))
+      (wire-function
+       "callable:numeric"
+       (wire-signature
+        (list (wire-parameter "value" "callable:number"))
+        "callable:number"))
+      (wire-primitive "callable:number" "number")
+      (wire-function
+       "callable:right"
+       (wire-signature
+        (list (wire-parameter "value" "callable:string"))
+        "callable:number"))
+      (wire-primitive "callable:string" "string"))))
+  (define interface-id (foreign-interface-v1-semantic-id interface))
+  (define (callable node-id) (type-foreign interface-id node-id))
+  (parameterize ([current-foreign-interfaces (hash interface-id interface)])
+    (check-equal?
+     (foreign-call-v1
+      (type-union
+       (list (callable "callable:left") (callable "callable:right")))
+      (list "value")
+      (list STRING))
+     (type-union (list STRING FLOAT)))
+    (check-foreign-error/in
+     interface-id
+     'overload-mismatch
+     "callable:numeric"
+     (lambda ()
+       (foreign-call-v1
+        (type-union
+         (list (callable "callable:left") (callable "callable:numeric")))
+        (list "value")
+        (list STRING))))
+    (void)))
+
 (test-foreign-query INTERFACE
  "repeated generic variables reject incompatible evidence"
   (check-equal?