From 334b176b9f560a393f0a210f288dd353f5708ffb Mon Sep 17 00:00:00 2001
From: Florian Angeletti <florian.angeletti@inria.fr>
Date: Tue, 24 Aug 2021 16:54:15 +0200
Subject: Merge pull request #10558 from Octachron/apply_selective_typing_prim

(cherry picked from commit 1bd0e663b6fcd72879172e176b32b3a9efddad2d)
---
 Changes                                   |  5 ++++
 testsuite/tests/prim-revapply/apply.ml    | 17 +++++++++++++
 testsuite/tests/prim-revapply/revapply.ml | 17 +++++++++++++
 typing/typecore.ml                        | 40 +++++++++++++++++++++++++++----
 4 files changed, 75 insertions(+), 4 deletions(-)

diff --git a/Changes b/Changes
index a7bf2c633f..4826c38847 100644
--- a/Changes
+++ b/Changes
@@ -575,6 +575,11 @@ OCaml 4.13.0
   (Damien Doligez, report by Stephen Dolan, review by Nicolás Ojeda Bär and
    Sadiq Jaffer)
 
+- #10450, #10558: keep %apply and %revapply primitives working with abstract
+  types. This breach of backward compatibility was only present in the alpha
+  releases of OCaml 4.13.0 .
+  (Florian Angeletti, review by Thomas Refis and Leo White)
+
 - #10454: Check row_more in nondep_type_rec.
   (Leo White, review by Thomas Refis)
 
diff --git a/testsuite/tests/prim-revapply/apply.ml b/testsuite/tests/prim-revapply/apply.ml
index 94a17b272b..685b326344 100644
--- a/testsuite/tests/prim-revapply/apply.ml
+++ b/testsuite/tests/prim-revapply/apply.ml
@@ -42,3 +42,20 @@ let _ =
 (* PR#10081 *)
 let bump ?(cap = 100) x = min cap (x + 1)
 let _f x = bump @@ x (* no warning 48 *)
+
+(* Abstract functions *)
+let _ =
+  let module A:sig
+    type f
+    type x
+    val succ: f
+    val zero:x
+    external (@@): f -> x -> int = "%apply"
+  end = struct
+    type f = int -> int
+    type x = int
+    let succ = succ
+    let zero = 0
+    external (@@): f -> x -> int = "%apply"
+  end in
+  A.(succ @@ zero)
diff --git a/testsuite/tests/prim-revapply/revapply.ml b/testsuite/tests/prim-revapply/revapply.ml
index 4a72154724..f65b109da5 100644
--- a/testsuite/tests/prim-revapply/revapply.ml
+++ b/testsuite/tests/prim-revapply/revapply.ml
@@ -30,3 +30,20 @@ let _f x = x |> bump (* no warning 48 *)
 type t = A | B
 type s = A | B
 let _f (x : t) = x |> function A -> 0 | B -> 1
+
+(* Abstract functions *)
+let _ =
+  let module A:sig
+    type f
+    type x
+    val succ: f
+    val zero:x
+    external (|>): x -> f -> int = "%revapply"
+  end = struct
+    type f = int -> int
+    type x = int
+    let succ = succ
+    let zero = 0
+    external (|>): x -> f -> int = "%revapply"
+  end in
+  A.(zero |> succ)
diff --git a/typing/typecore.ml b/typing/typecore.ml
index ac656fd1ef..87d4a55572 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -2714,6 +2714,34 @@ let rec is_inferred sexp =
   | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2
   | _ -> false
 
+(* check if the type of %apply or %revapply matches the type expected by
+   the specialized typing rule for those primitives.
+*)
+type apply_prim =
+  | Apply
+  | Revapply
+let check_apply_prim_type prim typ =
+  match (repr typ).desc with
+  | Tarrow (Nolabel,a,b,_) ->
+      begin match (repr b).desc with
+      | Tarrow(Nolabel,c,d,_) ->
+          let f, x, res =
+            match prim with
+            | Apply -> a, c, d
+            | Revapply -> c, a, d
+          in
+          let f, x, res = repr f, repr x, repr res in
+          begin match f.desc with
+          | Tarrow(Nolabel,fl,fr,_) ->
+              let fl, fr = repr fl, repr fr in
+              is_Tvar fl && is_Tvar fr && is_Tvar x && is_Tvar res
+              && fl == x && fr == res
+          | _ -> false
+          end
+      | _ -> false
+      end
+  | _ -> false
+
 (* Merge explanation to type clash error *)
 
 let with_explanation explanation f =
@@ -2919,12 +2947,16 @@ and type_expect_
       let funct, sargs =
         let funct = type_sfunct sfunct in
         match funct.exp_desc, sargs with
-        | Texp_ident (_, _, {val_kind = Val_prim {prim_name = "%revapply"}}),
+        | Texp_ident (_, _,
+                      {val_kind = Val_prim {prim_name="%revapply"}; val_type}),
           [Nolabel, sarg; Nolabel, actual_sfunct]
-          when is_inferred actual_sfunct ->
+          when is_inferred actual_sfunct
+            && check_apply_prim_type Revapply val_type ->
             type_sfunct actual_sfunct, [Nolabel, sarg]
-        | Texp_ident (_, _, {val_kind = Val_prim {prim_name = "%apply"}}),
-          [Nolabel, actual_sfunct; Nolabel, sarg] ->
+        | Texp_ident (_, _,
+                      {val_kind = Val_prim {prim_name="%apply"}; val_type}),
+          [Nolabel, actual_sfunct; Nolabel, sarg]
+          when check_apply_prim_type Apply val_type ->
             type_sfunct actual_sfunct, [Nolabel, sarg]
         | _ ->
             funct, sargs
-- 
cgit v1.2.1