Merge PR #13118: [type classes] Simplify cl_context

Reviewed-by: ppedrot

1 files changed, 30 insertions, 23 deletions

diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml
index 4016a3600e..2853eef5c5 100644
--- a/interp/implicit_quantifiers.ml
+++ b/interp/implicit_quantifiers.ml
@@ -122,15 +122,24 @@ let next_name_away_from na avoid =
   | Anonymous -> make_fresh avoid (Global.env ()) (Id.of_string "anon")
   | Name id -> make_fresh avoid (Global.env ()) id
 
+let rec is_class_arg c =
+  let open Constr in
+  match kind c with
+  | Prod (_,_,c)
+  | Cast (c,_,_)
+  | LetIn (_,_,_,c) -> is_class_arg c
+  | _ ->
+    let c, _ = decompose_appvect c in
+    match destRef c with
+    | exception DestKO -> false
+    | r, _ -> is_class r
+
 let combine_params avoid applied needed =
   let named, applied =
     List.partition
       (function
           (t, Some {CAst.loc;v=ExplByName id}) ->
-            let is_id (_, decl) = match RelDecl.get_name decl with
-            | Name id' -> Id.equal id id'
-            | Anonymous -> false
-            in
+            let is_id decl = Name.equal (Name id) (RelDecl.get_name decl) in
             if not (List.exists is_id needed) then
               user_err ?loc  (str "Wrong argument name: " ++ Id.print id);
             true
@@ -141,27 +150,27 @@ let combine_params avoid applied needed =
     named
   in
   let rec aux ids avoid app need =
-    match app, need with
-
-      | _, (_, LocalDef _) :: need -> aux ids avoid app need
-
-      | [], [] -> List.rev ids, avoid
+    match need with
+    | [] -> begin match app with
+        | [] -> List.rev ids, avoid
+        | (x, _) :: _ -> user_err ?loc:(Constrexpr_ops.constr_loc x) (str "Typeclass does not expect more arguments")
+      end
 
-      | app, (_, (LocalAssum ({binder_name=Name id}, _))) :: need when Id.List.mem_assoc id named ->
-          aux (Id.List.assoc id named :: ids) avoid app need
+    | LocalDef _ :: need -> aux ids avoid app need
 
-      | (x, None) :: app, (None, (LocalAssum ({binder_name=Name id}, _))) :: need ->
-          aux (x :: ids) avoid app need
 
-      | x :: app, (None, _) :: need -> aux (fst x :: ids) avoid app need
+    | LocalAssum ({binder_name=Name id}, _) :: need when Id.List.mem_assoc id named ->
+      aux (Id.List.assoc id named :: ids) avoid app need
 
-      | _, (Some _, decl) :: need | [], (None, decl) :: need ->
-        let id' = next_name_away_from (RelDecl.get_name decl) avoid in
-        let t' = CAst.make @@ CRef (qualid_of_ident id',None) in
-        aux (t' :: ids) (Id.Set.add id' avoid) app need
+    | decl :: need ->
+      begin match app, is_class_arg (get_type decl) with
+        | (x, _) :: app, false -> aux (x :: ids) avoid app need
 
-      | (x,_) :: _, [] ->
-          user_err ?loc:(Constrexpr_ops.constr_loc x) (str "Typeclass does not expect more arguments")
+        | [], false | _, true ->
+          let id' = next_name_away_from (RelDecl.get_name decl) avoid in
+          let t' = CAst.make @@ CRef (qualid_of_ident id',None) in
+          aux (t' :: ids) (Id.Set.add id' avoid) app need
+      end
   in
   aux [] avoid applied needed
 
@@ -190,9 +199,7 @@ let implicit_application env ty =
     let env = Global.env () in
     let sigma = Evd.from_env env in
     let c = class_info env sigma gr in
-    let (ci, rd) = c.cl_context in
-    let pars = List.rev (List.combine ci rd) in
-    let args, avoid = combine_params avoid par pars in
+    let args, avoid = combine_params avoid par (List.rev c.cl_context) in
     CAst.make ?loc @@ CAppExpl ((None, id, inst), args), avoid
 
 let warn_ignoring_implicit_status =