From e3a1cf35313bbc4eaca2a43f5fc95ca306bc45fa Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Mon, 28 Sep 2020 11:14:23 +0200
Subject: Remove the forward class hint feature.

It was not documented, not properly tested and thus likely buggy. Judging
from the code alone I spotted already one potential bug. Further more it was
prominently making use of the infamous "arbitrary term as hint" feature.

Since the only user in our CI seems to be a math-classes file that introduced
the feature under a claim of "cleanup", I believe we can safely remove it
without anyone noticing.
---
 pretyping/typeclasses.ml  | 63 +----------------------------------------------
 pretyping/typeclasses.mli | 10 +-------
 2 files changed, 2 insertions(+), 71 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index adb9c5299f..78f04c99e5 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -11,7 +11,6 @@
 (*i*)
 open Names
 open Globnames
-open Term
 open Constr
 open Vars
 open Evd
@@ -42,7 +41,7 @@ let get_solve_one_instance, solve_one_instance_hook = Hook.make ()
 let resolve_one_typeclass ?(unique=get_typeclasses_unique_solutions ()) env evm t =
   Hook.get get_solve_one_instance env evm t unique
 
-type direction = Forward | Backward
+type direction = Backward
 
 (* This module defines type-classes *)
 type typeclass = {
@@ -156,66 +155,6 @@ let load_class cl =
 
 (** Build the subinstances hints. *)
 
-let check_instance env sigma c =
-  try
-    let (evd, c) = resolve_one_typeclass env sigma
-      (Retyping.get_type_of env sigma c) in
-      not (Evd.has_undefined evd)
-  with e when CErrors.noncritical e -> false
-
-let build_subclasses ~check env sigma glob { hint_priority = pri } =
-  let _id = Nametab.basename_of_global glob in
-  let _next_id =
-    let i = ref (-1) in
-      (fun () -> incr i;
-        Nameops.add_suffix _id ("_subinstance_" ^ string_of_int !i))
-  in
-  let ty, ctx = Typeops.type_of_global_in_context env glob in
-  let inst, ctx = UnivGen.fresh_instance_from ctx None in
-  let ty = Vars.subst_instance_constr inst ty in
-  let ty = EConstr.of_constr ty in
-  let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in
-  let rec aux pri c ty path =
-      match class_of_constr env sigma ty with
-      | None -> []
-      | Some (rels, ((tc,u), args)) ->
-        let instapp =
-          Reductionops.whd_beta env sigma (EConstr.of_constr (appvectc c (Context.Rel.to_extended_vect mkRel 0 rels)))
-        in
-        let instapp = EConstr.Unsafe.to_constr instapp in
-        let projargs = Array.of_list (args @ [instapp]) in
-        let projs = List.map_filter
-          (fun (n, b, proj) ->
-           match b with
-           | None -> None
-           | Some (Backward, _) -> None
-           | Some (Forward, info) ->
-             let proj = Option.get proj in
-             let rels = List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) rels in
-             let u = EConstr.EInstance.kind sigma u in
-             let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in
-               if check && check_instance env sigma (EConstr.of_constr body) then None
-               else
-                 let newpri =
-                   match pri, info.hint_priority with
-                   | Some p, Some p' -> Some (p + p')
-                   | Some p, None -> Some (p + 1)
-                   | _, _ -> None
-                 in
-                   Some (GlobRef.ConstRef proj, { info with hint_priority = newpri }, body)) tc.cl_projs
-        in
-        let declare_proj hints (cref, info, body) =
-          let path' = cref :: path in
-          let ty = Retyping.get_type_of env sigma (EConstr.of_constr body) in
-          let rest = aux pri body ty path' in
-            hints @ (path', info, body) :: rest
-        in List.fold_left declare_proj [] projs
-  in
-  let term = Constr.mkRef (glob, inst) in
-    (*FIXME subclasses should now get substituted for each particular instance of
-      the polymorphic superclass *)
-    aux pri term ty [glob]
-
 (*
  * interface functions
  *)
diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli
index 9de8083276..c0e71f26c4 100644
--- a/pretyping/typeclasses.mli
+++ b/pretyping/typeclasses.mli
@@ -13,7 +13,7 @@ open Constr
 open Evd
 open Environ
 
-type direction = Forward | Backward
+type direction = Backward
 
 (* Core typeclasses hints *)
 type 'a hint_info_gen =
@@ -127,11 +127,3 @@ val classes_transparent_state : unit -> TransparentState.t
 
 val solve_all_instances_hook : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) Hook.t
 val solve_one_instance_hook : (env -> evar_map -> EConstr.types -> bool -> evar_map * EConstr.constr) Hook.t
-
-(** Build the subinstances hints for a given typeclass object.
-    check tells if we should check for existence of the
-    subinstances and add only the missing ones. *)
-
-val build_subclasses : check:bool -> env -> evar_map -> GlobRef.t ->
-                       hint_info ->
-                       (GlobRef.t list * hint_info * constr) list
-- 
cgit v1.2.3


From f16290030b48dedf3091334af4cd21a7df157381 Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Wed, 30 Sep 2020 13:21:02 +0200
Subject: Further simplification of the typeclass registration API.

---
 pretyping/typeclasses.ml  |  9 ++++++---
 pretyping/typeclasses.mli | 10 +++++++---
 2 files changed, 13 insertions(+), 6 deletions(-)

(limited to 'pretyping')

diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index 78f04c99e5..fc71254a46 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -41,7 +41,11 @@ let get_solve_one_instance, solve_one_instance_hook = Hook.make ()
 let resolve_one_typeclass ?(unique=get_typeclasses_unique_solutions ()) env evm t =
   Hook.get get_solve_one_instance env evm t unique
 
-type direction = Backward
+type class_method = {
+  meth_name : Name.t;
+  meth_info : hint_info option;
+  meth_const : Constant.t option;
+}
 
 (* This module defines type-classes *)
 type typeclass = {
@@ -58,8 +62,7 @@ type typeclass = {
   cl_props : Constr.rel_context;
 
   (* The method implementations as projections. *)
-  cl_projs : (Name.t * (direction * hint_info) option
-              * Constant.t option) list;
+  cl_projs : class_method list;
 
   cl_strict : bool;
 
diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli
index c0e71f26c4..3f84d08a7e 100644
--- a/pretyping/typeclasses.mli
+++ b/pretyping/typeclasses.mli
@@ -13,8 +13,6 @@ open Constr
 open Evd
 open Environ
 
-type direction = Backward
-
 (* Core typeclasses hints *)
 type 'a hint_info_gen =
     { hint_priority : int option;
@@ -22,6 +20,12 @@ type 'a hint_info_gen =
 
 type hint_info = (Pattern.patvar list * Pattern.constr_pattern) hint_info_gen
 
+type class_method = {
+  meth_name : Name.t;
+  meth_info : hint_info option;
+  meth_const : Constant.t option;
+}
+
 (** This module defines type-classes *)
 type typeclass = {
   cl_univs : Univ.AUContext.t;
@@ -39,7 +43,7 @@ type typeclass = {
   cl_props : Constr.rel_context;
   (** Context of definitions and properties on defs, will not be shared *)
 
-  cl_projs : (Name.t * (direction * hint_info) option * Constant.t option) list;
+  cl_projs : class_method list;
   (** The methods implementations of the typeclass as projections.
       Some may be undefinable due to sorting restrictions or simply undefined if
       no name is provided. The [int option option] indicates subclasses whose hint has
-- 
cgit v1.2.3