aboutsummaryrefslogtreecommitdiff
path: root/pretyping
diff options
context:
space:
mode:
Diffstat (limited to 'pretyping')
-rw-r--r--pretyping/evarsolve.ml34
-rw-r--r--pretyping/pretype_errors.ml1
-rw-r--r--pretyping/pretype_errors.mli1
-rw-r--r--pretyping/typeclasses.ml70
-rw-r--r--pretyping/typeclasses.mli18
5 files changed, 34 insertions, 90 deletions
diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index 4d5715a391..715b80f428 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -1196,8 +1196,8 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs =
let filter_compatible_candidates unify flags env evd evi args rhs c =
let c' = instantiate_evar_array evi c args in
match unify flags TermUnification env evd Reduction.CONV rhs c' with
- | Success evd -> Some (c,evd)
- | UnifFailure _ -> None
+ | Success evd -> Inl (c,evd)
+ | UnifFailure _ -> Inr c'
(* [restrict_candidates ... filter ev1 ev2] restricts the candidates
of ev1, removing those not compatible with the filter, as well as
@@ -1218,8 +1218,8 @@ let restrict_candidates unify flags env evd filter1 (evk1,argsv1) (evk2,argsv2)
let filter c2 =
let compatibility = filter_compatible_candidates unify flags env evd evi2 argsv2 c1' c2 in
match compatibility with
- | None -> false
- | Some _ -> true
+ | Inl _ -> true
+ | Inr _ -> false
in
let filtered = List.filter filter l2 in
match filtered with [] -> false | _ -> true) l1 in
@@ -1440,29 +1440,33 @@ let solve_refl ?(can_drop=false) unify flags env evd pbty evk argsv1 argsv2 =
in advance, we check which of them apply *)
exception NoCandidates
-exception IncompatibleCandidates
+exception IncompatibleCandidates of EConstr.t
let solve_candidates unify flags env evd (evk,argsv) rhs =
let evi = Evd.find evd evk in
match evi.evar_candidates with
| None -> raise NoCandidates
| Some l ->
- let l' =
- List.map_filter
- (fun c -> filter_compatible_candidates unify flags env evd evi argsv rhs c) l in
- match l' with
- | [] -> raise IncompatibleCandidates
- | [c,evd] ->
+ let rec aux = function
+ | [] -> [], []
+ | c::l ->
+ let compatl, disjointl = aux l in
+ match filter_compatible_candidates unify flags env evd evi argsv rhs c with
+ | Inl c -> c::compatl, disjointl
+ | Inr c -> compatl, c::disjointl in
+ match aux l with
+ | [], c::_ -> raise (IncompatibleCandidates c)
+ | [c,evd], _ ->
(* solve_candidates might have been called recursively in the mean *)
(* time and the evar been solved by the filtering process *)
if Evd.is_undefined evd evk then
let evd' = Evd.define evk c evd in
check_evar_instance unify flags env evd' evk c
else evd
- | l when List.length l < List.length l' ->
+ | l, _::_ (* At least one discarded candidate *) ->
let candidates = List.map fst l in
restrict_evar evd evk None (UpdateWith candidates)
- | l -> evd
+ | l, [] -> evd
let occur_evar_upto_types sigma n c =
let c = EConstr.Unsafe.to_constr c in
@@ -1794,6 +1798,6 @@ let solve_simple_eqn unify flags ?(choose=false) ?(imitate_defs=true)
UnifFailure (evd,MetaOccurInBody evk1)
| IllTypedInstance (env,t,u) ->
UnifFailure (evd,InstanceNotSameType (evk1,env,t,u))
- | IncompatibleCandidates ->
- UnifFailure (evd,ConversionFailed (env,mkEvar ev1,t2))
+ | IncompatibleCandidates t ->
+ UnifFailure (evd,IncompatibleInstances (env,ev1,t,t2))
diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml
index 207ffc7b86..1e8441dd8a 100644
--- a/pretyping/pretype_errors.ml
+++ b/pretyping/pretype_errors.ml
@@ -20,6 +20,7 @@ type unification_error =
| NotSameHead
| NoCanonicalStructure
| ConversionFailed of env * constr * constr (* Non convertible closed terms *)
+ | IncompatibleInstances of env * existential * constr * constr
| MetaOccurInBody of Evar.t
| InstanceNotSameType of Evar.t * env * types * types
| UnifUnivInconsistency of Univ.univ_inconsistency
diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli
index 70f218d617..45997e9a66 100644
--- a/pretyping/pretype_errors.mli
+++ b/pretyping/pretype_errors.mli
@@ -23,6 +23,7 @@ type unification_error =
| NotSameHead
| NoCanonicalStructure
| ConversionFailed of env * constr * constr
+ | IncompatibleInstances of env * existential * constr * constr
| MetaOccurInBody of Evar.t
| InstanceNotSameType of Evar.t * env * types * types
| UnifUnivInconsistency of Univ.univ_inconsistency
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index adb9c5299f..fc71254a46 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,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 = Forward | 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 = {
@@ -59,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;
@@ -156,66 +158,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..3f84d08a7e 100644
--- a/pretyping/typeclasses.mli
+++ b/pretyping/typeclasses.mli
@@ -13,8 +13,6 @@ open Constr
open Evd
open Environ
-type direction = Forward | 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
@@ -127,11 +131,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
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-09 08:17:41 +0000