diff options
| -rw-r--r-- | tactics/hints.ml | 2 | ||||
| -rw-r--r-- | tactics/hints.mli | 6 | ||||
| -rw-r--r-- | vernac/classes.ml | 2 | ||||
| -rw-r--r-- | vernac/comHints.ml | 21 |
4 files changed, 15 insertions, 16 deletions
diff --git a/tactics/hints.ml b/tactics/hints.ml index b8bd459616..2bff610b00 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1347,6 +1347,8 @@ let add_hints ~locality dbnames h = | HintsExternEntry (info, tacexp) -> add_externs info tacexp ~local ~superglobal dbnames +let hint_globref gr = IsGlobRef gr + let hint_constr env sigma ~poly c = let c, diff = prepare_hint true env sigma c in let diff, uctx = diff --git a/tactics/hints.mli b/tactics/hints.mli index e74519f12a..eb0f937302 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -167,9 +167,7 @@ type hint_db = Hint_db.t type hnf = bool -type hint_term = - | IsGlobRef of GlobRef.t - | IsConstr of constr * Univ.ContextSet.t option [@ocaml.deprecated "Declare a hint constant instead"] +type hint_term type hints_entry = | HintsResolveEntry of (hint_info * hnf * hints_path_atom * hint_term) list @@ -199,6 +197,8 @@ val current_pure_db : unit -> hint_db list val add_hints : locality:Goptions.option_locality -> hint_db_name list -> hints_entry -> unit +val hint_globref : GlobRef.t -> hint_term + val hint_constr : env -> evar_map -> poly:bool -> evar_map * constr -> hint_term * Univ.ContextSet.t [@ocaml.deprecated "Declare a hint constant instead"] diff --git a/vernac/classes.ml b/vernac/classes.ml index d5509e2697..a100352145 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -57,7 +57,7 @@ let is_local_for_hint i = let add_instance_base inst = let locality = if is_local_for_hint inst then Goptions.OptLocal else Goptions.OptGlobal in - add_instance_hint (Hints.IsGlobRef inst.is_impl) [inst.is_impl] ~locality + add_instance_hint (Hints.hint_globref inst.is_impl) [inst.is_impl] ~locality inst.is_info let mk_instance cl info glob impl = diff --git a/vernac/comHints.ml b/vernac/comHints.ml index b5e53208ca..6cc1940b40 100644 --- a/vernac/comHints.ml +++ b/vernac/comHints.ml @@ -62,7 +62,7 @@ let project_hint ~poly pri l2r r = cb in let info = {Typeclasses.hint_priority = pri; hint_pattern = None} in - (info, true, Hints.PathAny, Hints.IsGlobRef (GlobRef.ConstRef c)) + (info, true, Hints.PathAny, Hints.hint_globref (GlobRef.ConstRef c)) let warn_deprecated_hint_constr = CWarnings.create ~name:"fragile-hint-constr" ~category:"automation" @@ -84,14 +84,6 @@ let soft_evaluable = let interp_hints ~poly h = let env = Global.env () in let sigma = Evd.from_env env in - let f poly c = - let env = Global.env () in - let sigma = Evd.from_env env in - let evd, c = Constrintern.interp_open_constr env sigma c in - let h, diff = Hints.hint_constr env sigma ~poly (evd, c) in - let () = DeclareUctx.declare_universe_context ~poly:false diff [@ocaml.warning "-3"] in - h - in let fref r = let gr = Smartlocate.global_with_alias r in Dumpglob.add_glob ?loc:r.CAst.loc gr; @@ -104,10 +96,15 @@ let interp_hints ~poly h = match c with | HintsReference c -> let gr = Smartlocate.global_with_alias c in - (PathHints [gr], IsGlobRef gr) + (PathHints [gr], hint_globref gr) | HintsConstr c -> let () = warn_deprecated_hint_constr () in - (PathAny, f poly c) + let env = Global.env () in + let sigma = Evd.from_env env in + let evd, c = Constrintern.interp_open_constr env sigma c in + let h, diff = Hints.hint_constr env sigma ~poly (evd, c) in + let () = DeclareUctx.declare_universe_context ~poly:false diff [@ocaml.warning "-3"] in + (PathAny, h) in let fp = Constrintern.intern_constr_pattern env sigma in let fres (info, b, r) = @@ -147,7 +144,7 @@ let interp_hints ~poly h = ( empty_hint_info , true , PathHints [gr] - , IsGlobRef gr )) + , hint_globref gr )) in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) | HintsExtern (pri, patcom, tacexp) -> |