aboutsummaryrefslogtreecommitdiff
path: root/tactics
diff options
context:
space:
mode:
Diffstat (limited to 'tactics')
-rw-r--r--tactics/autorewrite.ml10
-rw-r--r--tactics/autorewrite.mli6
-rw-r--r--tactics/contradiction.ml2
-rw-r--r--tactics/equality.ml2
-rw-r--r--tactics/hints.ml4
-rw-r--r--tactics/hipattern.ml20
-rw-r--r--tactics/inv.ml4
-rw-r--r--tactics/tacticals.ml26
-rw-r--r--tactics/tacticals.mli2
-rw-r--r--tactics/tactics.ml120
10 files changed, 97 insertions, 99 deletions
diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml
index 2d54b61c72..68f72d7aed 100644
--- a/tactics/autorewrite.ml
+++ b/tactics/autorewrite.ml
@@ -84,7 +84,7 @@ let print_rewrite_hintdb bas =
Pputils.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac)
(find_rewrites bas))
-type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option
+type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option) Loc.located
(* Applies all the rules of one base *)
let one_base general_rewrite_maybe_in tac_main bas =
@@ -257,12 +257,12 @@ let decompose_applied_relation metas env sigma c ctype left2right =
| Some c -> Some c
| None -> None
-let find_applied_relation metas loc env sigma c left2right =
+let find_applied_relation ?loc metas env sigma c left2right =
let ctype = Typing.unsafe_type_of env sigma (EConstr.of_constr c) in
match decompose_applied_relation metas env sigma c ctype left2right with
| Some c -> c
| None ->
- user_err ~loc ~hdr:"decompose_applied_relation"
+ user_err ?loc ~hdr:"decompose_applied_relation"
(str"The type" ++ spc () ++ Printer.pr_econstr_env env sigma ctype ++
spc () ++ str"of this term does not end with an applied relation.")
@@ -275,9 +275,9 @@ let add_rew_rules base lrul =
let intern tac = snd (Genintern.generic_intern ist tac) in
let lrul =
List.fold_left
- (fun dn (loc,(c,ctx),b,t) ->
+ (fun dn (loc,((c,ctx),b,t)) ->
let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in
- let info = find_applied_relation false loc env sigma c b in
+ let info = find_applied_relation ?loc false env sigma c b in
let pat = if b then info.hyp_left else info.hyp_right in
let rul = { rew_lemma = c; rew_type = info.hyp_ty;
rew_pat = pat; rew_ctx = ctx; rew_l2r = b;
diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli
index 49e8588da3..f765318d04 100644
--- a/tactics/autorewrite.mli
+++ b/tactics/autorewrite.mli
@@ -12,7 +12,7 @@ open Term
open Equality
(** Rewriting rules before tactic interpretation *)
-type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option
+type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option) Loc.located
(** To add rewriting rules to a base *)
val add_rew_rules : string -> raw_rew_rule list -> unit
@@ -56,7 +56,7 @@ type hypinfo = {
hyp_right : constr;
}
-val find_applied_relation : bool ->
- Loc.t ->
+val find_applied_relation :
+ ?loc:Loc.t -> bool ->
Environ.env -> Evd.evar_map -> Term.constr -> bool -> hypinfo
diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml
index 63f923dfd3..768d6860dc 100644
--- a/tactics/contradiction.ml
+++ b/tactics/contradiction.ml
@@ -31,7 +31,7 @@ let absurd c =
let env = Proofview.Goal.env gl in
let sigma = Sigma.to_evar_map sigma in
let j = Retyping.get_judgment_of env sigma c in
- let sigma, j = Coercion.inh_coerce_to_sort Loc.ghost env sigma j in
+ let sigma, j = Coercion.inh_coerce_to_sort env sigma j in
let t = j.Environ.utj_val in
let tac =
Tacticals.New.tclTHENLIST [
diff --git a/tactics/equality.ml b/tactics/equality.ml
index 18a1f02011..b0f27663e8 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -1478,7 +1478,7 @@ let simpleInjClause with_evars = function
| Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (injEq ~old:true with_evars clear_flag None)) c
let injConcl = injClause None false None
-let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (Loc.ghost,id)))
+let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (Loc.tag id)))
let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause =
Proofview.Goal.enter { enter = begin fun gl ->
diff --git a/tactics/hints.ml b/tactics/hints.ml
index c5bacc5a20..61bc3d2844 100644
--- a/tactics/hints.ml
+++ b/tactics/hints.ml
@@ -1277,7 +1277,7 @@ let interp_hints poly =
prepare_hint true (poly,false) (Global.env()) Evd.empty (evd,c) in
let fref r =
let gr = global_with_alias r in
- Dumpglob.add_glob (loc_of_reference r) gr;
+ Dumpglob.add_glob ?loc:(loc_of_reference r) gr;
gr in
let fr r =
evaluable_of_global_reference (Global.env()) (fref r)
@@ -1306,7 +1306,7 @@ let interp_hints poly =
let constr_hints_of_ind qid =
let ind = global_inductive_with_alias qid in
let mib,_ = Global.lookup_inductive ind in
- Dumpglob.dump_reference (fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind";
+ Dumpglob.dump_reference ?loc:(fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind";
List.init (nconstructors ind)
(fun i -> let c = (ind,i+1) in
let gr = ConstructRef c in
diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml
index 15b40b42d1..dce98eed74 100644
--- a/tactics/hipattern.ml
+++ b/tactics/hipattern.ml
@@ -252,16 +252,16 @@ open Decl_kinds
open Evar_kinds
let mkPattern c = snd (Patternops.pattern_of_glob_constr c)
-let mkGApp f args = GApp (Loc.ghost, f, args)
-let mkGHole =
- GHole (Loc.ghost, QuestionMark (Define false), Misctypes.IntroAnonymous, None)
-let mkGProd id c1 c2 =
- GProd (Loc.ghost, Name (Id.of_string id), Explicit, c1, c2)
-let mkGArrow c1 c2 =
- GProd (Loc.ghost, Anonymous, Explicit, c1, c2)
-let mkGVar id = GVar (Loc.ghost, Id.of_string id)
-let mkGPatVar id = GPatVar(Loc.ghost, (false, Id.of_string id))
-let mkGRef r = GRef (Loc.ghost, Lazy.force r, None)
+let mkGApp f args = CAst.make @@ GApp (f, args)
+let mkGHole = CAst.make @@
+ GHole (QuestionMark (Define false), Misctypes.IntroAnonymous, None)
+let mkGProd id c1 c2 = CAst.make @@
+ GProd (Name (Id.of_string id), Explicit, c1, c2)
+let mkGArrow c1 c2 = CAst.make @@
+ GProd (Anonymous, Explicit, c1, c2)
+let mkGVar id = CAst.make @@ GVar (Id.of_string id)
+let mkGPatVar id = CAst.make @@ GPatVar((false, Id.of_string id))
+let mkGRef r = CAst.make @@ GRef (Lazy.force r, None)
let mkGAppRef r args = mkGApp (mkGRef r) args
(** forall x : _, _ x x *)
diff --git a/tactics/inv.ml b/tactics/inv.ml
index 266cac5c7d..5c4b73a622 100644
--- a/tactics/inv.ml
+++ b/tactics/inv.ml
@@ -282,9 +282,9 @@ let generalizeRewriteIntros as_mode tac depids id =
end }
let error_too_many_names pats =
- let loc = Loc.join_loc (fst (List.hd pats)) (fst (List.last pats)) in
+ let loc = Loc.merge_opt (fst (List.hd pats)) (fst (List.last pats)) in
Proofview.tclENV >>= fun env ->
- tclZEROMSG ~loc (
+ tclZEROMSG ?loc (
str "Unexpected " ++
str (String.plural (List.length pats) "introduction pattern") ++
str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (EConstr.Unsafe.to_constr (fst (run_delayed env Evd.empty c))))) pats ++
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index c8441a8cc9..fe9cb123ce 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -169,23 +169,23 @@ let fix_empty_or_and_pattern nv l =
| IntroOrPattern [[]] -> IntroOrPattern (List.make nv [])
| _ -> l
-let check_or_and_pattern_size check_and loc names branchsigns =
+let check_or_and_pattern_size ?loc check_and names branchsigns =
let n = Array.length branchsigns in
let msg p1 p2 = strbrk "a conjunctive pattern made of " ++ int p1 ++ (if p1 == p2 then mt () else str " or " ++ int p2) ++ str " patterns" in
let err1 p1 p2 =
- user_err ~loc (str "Expects " ++ msg p1 p2 ++ str ".") in
+ user_err ?loc (str "Expects " ++ msg p1 p2 ++ str ".") in
let errn n =
- user_err ~loc (str "Expects a disjunctive pattern with " ++ int n
+ user_err ?loc (str "Expects a disjunctive pattern with " ++ int n
++ str " branches.") in
let err1' p1 p2 =
- user_err ~loc (strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in
- let errforthcoming loc =
- user_err ~loc (strbrk "Unexpected non atomic pattern.") in
+ user_err ?loc (strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in
+ let errforthcoming ?loc =
+ user_err ?loc (strbrk "Unexpected non atomic pattern.") in
match names with
| IntroAndPattern l ->
if not (Int.equal n 1) then errn n;
let l' = List.filter (function _,IntroForthcoming _ -> true | _,IntroNaming _ | _,IntroAction _ -> false) l in
- if l' != [] then errforthcoming (fst (List.hd l'));
+ if l' != [] then errforthcoming ?loc:(fst (List.hd l'));
if check_and then
let p1 = List.count (fun x -> x) branchsigns.(0) in
let p2 = List.length branchsigns.(0) in
@@ -193,7 +193,7 @@ let check_or_and_pattern_size check_and loc names branchsigns =
if not (Int.equal p p1 || Int.equal p p2) then err1 p1 p2;
if Int.equal p p1 then
IntroAndPattern
- (List.extend branchsigns.(0) (Loc.ghost,IntroNaming IntroAnonymous) l)
+ (List.extend branchsigns.(0) (Loc.tag @@ IntroNaming IntroAnonymous) l)
else
names
else
@@ -206,20 +206,20 @@ let check_or_and_pattern_size check_and loc names branchsigns =
err1' p1 p2 else errn n;
names
-let get_and_check_or_and_pattern_gen check_and loc names branchsigns =
- let names = check_or_and_pattern_size check_and loc names branchsigns in
+let get_and_check_or_and_pattern_gen ?loc check_and names branchsigns =
+ let names = check_or_and_pattern_size ?loc check_and names branchsigns in
match names with
| IntroAndPattern l -> [|l|]
| IntroOrPattern l -> Array.of_list l
-let get_and_check_or_and_pattern = get_and_check_or_and_pattern_gen true
+let get_and_check_or_and_pattern ?loc = get_and_check_or_and_pattern_gen ?loc true
let compute_induction_names_gen check_and branchletsigns = function
| None ->
Array.make (Array.length branchletsigns) []
| Some (loc,names) ->
let names = fix_empty_or_and_pattern (Array.length branchletsigns) names in
- get_and_check_or_and_pattern_gen check_and loc names branchletsigns
+ get_and_check_or_and_pattern_gen check_and ?loc names branchletsigns
let compute_induction_names = compute_induction_names_gen true
@@ -490,7 +490,7 @@ module New = struct
| [] -> ()
| (evk,evi) :: _ ->
let (loc,_) = evi.Evd.evar_source in
- Pretype_errors.error_unsolvable_implicit ~loc env sigma evk None
+ Pretype_errors.error_unsolvable_implicit ?loc env sigma evk None
let tclWITHHOLES accept_unresolved_holes tac sigma =
tclEVARMAP >>= fun sigma_initial ->
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
index 5a4ecbac75..96270f748e 100644
--- a/tactics/tacticals.mli
+++ b/tactics/tacticals.mli
@@ -114,7 +114,7 @@ type branch_assumptions = private {
error message if |pats| <> |branchsign|; extends them if no pattern is given
for let-ins in the case of a conjunctive pattern *)
val get_and_check_or_and_pattern :
- Loc.t -> delayed_open_constr or_and_intro_pattern_expr ->
+ ?loc:Loc.t -> delayed_open_constr or_and_intro_pattern_expr ->
bool list array -> intro_patterns array
(** Tolerate "[]" to mean a disjunctive pattern of any length *)
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index 15cef676e6..11c2819857 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -53,8 +53,6 @@ module NamedDecl = Context.Named.Declaration
let inj_with_occurrences e = (AllOccurrences,e)
-let dloc = Loc.ghost
-
let typ_of env sigma c =
let open Retyping in
try get_type_of ~lax:true env (Sigma.to_evar_map sigma) c
@@ -427,11 +425,11 @@ let default_id env sigma decl =
type name_flag =
| NamingAvoid of Id.t list
| NamingBasedOn of Id.t * Id.t list
- | NamingMustBe of Loc.t * Id.t
+ | NamingMustBe of Id.t Loc.located
let naming_of_name = function
| Anonymous -> NamingAvoid []
- | Name id -> NamingMustBe (dloc,id)
+ | Name id -> NamingMustBe (Loc.tag id)
let find_name mayrepl decl naming gl = match naming with
| NamingAvoid idl ->
@@ -445,7 +443,7 @@ let find_name mayrepl decl naming gl = match naming with
let ids_of_hyps = Tacmach.New.pf_ids_of_hyps gl in
let id' = next_ident_away id ids_of_hyps in
if not mayrepl && not (Id.equal id' id) then
- user_err ~loc (pr_id id ++ str" is already used.");
+ user_err ?loc (pr_id id ++ str" is already used.");
id
(**************************************************************)
@@ -469,7 +467,7 @@ let assert_before_gen b naming t =
assert_before_then_gen b naming t (fun _ -> Proofview.tclUNIT ())
let assert_before na = assert_before_gen false (naming_of_name na)
-let assert_before_replacing id = assert_before_gen true (NamingMustBe (dloc,id))
+let assert_before_replacing id = assert_before_gen true (NamingMustBe (Loc.tag id))
let assert_after_then_gen b naming t tac =
let open Context.Rel.Declaration in
@@ -488,7 +486,7 @@ let assert_after_gen b naming t =
assert_after_then_gen b naming t (fun _ -> (Proofview.tclUNIT ()))
let assert_after na = assert_after_gen false (naming_of_name na)
-let assert_after_replacing id = assert_after_gen true (NamingMustBe (dloc,id))
+let assert_after_replacing id = assert_after_gen true (NamingMustBe (Loc.tag id))
(**************************************************************)
(* Fixpoints and CoFixpoints *)
@@ -972,7 +970,7 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac =
end }
let intro_gen n m f d = intro_then_gen n m f d (fun _ -> Proofview.tclUNIT ())
-let intro_mustbe_force id = intro_gen (NamingMustBe (dloc,id)) MoveLast true false
+let intro_mustbe_force id = intro_gen (NamingMustBe (Loc.tag id)) MoveLast true false
let intro_using id = intro_gen (NamingBasedOn (id,[])) MoveLast false false
let intro_then = intro_then_gen (NamingAvoid []) MoveLast false false
@@ -982,7 +980,7 @@ let intro_avoiding l = intro_gen (NamingAvoid l) MoveLast false false
let intro_move_avoid idopt avoid hto = match idopt with
| None -> intro_gen (NamingAvoid avoid) hto true false
- | Some id -> intro_gen (NamingMustBe (dloc,id)) hto true false
+ | Some id -> intro_gen (NamingMustBe (Loc.tag id)) hto true false
let intro_move idopt hto = intro_move_avoid idopt [] hto
@@ -1142,7 +1140,7 @@ let try_intros_until tac = function
let rec intros_move = function
| [] -> Proofview.tclUNIT ()
| (hyp,destopt) :: rest ->
- Tacticals.New.tclTHEN (intro_gen (NamingMustBe (dloc,hyp)) destopt false false)
+ Tacticals.New.tclTHEN (intro_gen (NamingMustBe (Loc.tag hyp)) destopt false false)
(intros_move rest)
let run_delayed env sigma c =
@@ -1294,7 +1292,7 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true)
error_uninstantiated_metas new_hyp_typ clenv;
let new_hyp_prf = clenv_value clenv in
let exact_tac = Proofview.V82.tactic (Tacmach.refine_no_check new_hyp_prf) in
- let naming = NamingMustBe (dloc,targetid) in
+ let naming = NamingMustBe (Loc.tag targetid) in
let with_clear = do_replace (Some id) naming in
Tacticals.New.tclTHEN
(Proofview.Unsafe.tclEVARS (clear_metas clenv.evd))
@@ -1739,7 +1737,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind :
with Redelimination ->
(* Last chance: if the head is a variable, apply may try
second order unification *)
- let info = Loc.add_loc info loc in
+ let info = Option.cata (fun loc -> Loc.add_loc info loc) info loc in
let tac =
if with_destruct then
descend_in_conjunctions []
@@ -1801,13 +1799,13 @@ let apply_with_delayed_bindings_gen b e l =
(one k f) (aux cbl)
in aux l
-let apply_with_bindings cb = apply_with_bindings_gen false false [None,(dloc,cb)]
+let apply_with_bindings cb = apply_with_bindings_gen false false [None,(Loc.tag cb)]
-let eapply_with_bindings cb = apply_with_bindings_gen false true [None,(dloc,cb)]
+let eapply_with_bindings cb = apply_with_bindings_gen false true [None,(Loc.tag cb)]
-let apply c = apply_with_bindings_gen false false [None,(dloc,(c,NoBindings))]
+let apply c = apply_with_bindings_gen false false [None,(Loc.tag (c,NoBindings))]
-let eapply c = apply_with_bindings_gen false true [None,(dloc,(c,NoBindings))]
+let eapply c = apply_with_bindings_gen false true [None,(Loc.tag (c,NoBindings))]
let apply_list = function
| c::l -> apply_with_bindings (c,ImplicitBindings l)
@@ -1843,8 +1841,8 @@ let progress_with_clause flags innerclause clause =
try List.find_map f ordered_metas
with Not_found -> raise UnableToApply
-let explain_unable_to_apply_lemma loc env sigma thm innerclause =
- user_err ~loc (hov 0
+let explain_unable_to_apply_lemma ?loc env sigma thm innerclause =
+ user_err ?loc (hov 0
(Pp.str "Unable to apply lemma of type" ++ brk(1,1) ++
Pp.quote (Printer.pr_leconstr_env env sigma thm) ++ spc() ++
str "on hypothesis of type" ++ brk(1,1) ++
@@ -1860,7 +1858,7 @@ let apply_in_once_main flags innerclause env sigma (loc,d,lbind) =
try aux (clenv_push_prod clause)
with NotExtensibleClause ->
match e with
- | UnableToApply -> explain_unable_to_apply_lemma loc env sigma thm innerclause
+ | UnableToApply -> explain_unable_to_apply_lemma ?loc env sigma thm innerclause
| _ -> iraise e'
in
aux (make_clenv_binding env sigma (d,thm) lbind)
@@ -2219,7 +2217,7 @@ let constructor_tac with_evars expctdnumopt i lbind =
(Proofview.Goal.env gl) sigma (fst mind, i) in
let cons = mkConstructU (cons, EInstance.make u) in
- let apply_tac = general_apply true false with_evars None (dloc,(cons,lbind)) in
+ let apply_tac = general_apply true false with_evars None (Loc.tag (cons,lbind)) in
let tac =
(Tacticals.New.tclTHENLIST
[
@@ -2286,7 +2284,7 @@ let error_unexpected_extra_pattern loc bound pat =
| IntroNaming (IntroIdentifier _) ->
"name", (String.plural nb " introduction pattern"), "no"
| _ -> "introduction pattern", "", "none" in
- user_err ~loc (str "Unexpected " ++ str s1 ++ str " (" ++
+ user_err ?loc (str "Unexpected " ++ str s1 ++ str " (" ++
(if Int.equal nb 0 then (str s3 ++ str s2) else
(str "at most " ++ int nb ++ str s2)) ++ spc () ++
str (if Int.equal nb 1 then "was" else "were") ++
@@ -2304,7 +2302,7 @@ let my_find_eq_data_decompose gl t =
-> None
| Constr_matching.PatternMatchingFailure -> None
-let intro_decomp_eq loc l thin tac id =
+let intro_decomp_eq ?loc l thin tac id =
Proofview.Goal.enter { enter = begin fun gl ->
let c = mkVar id in
let t = Tacmach.New.pf_unsafe_type_of gl c in
@@ -2312,13 +2310,13 @@ let intro_decomp_eq loc l thin tac id =
match my_find_eq_data_decompose gl t with
| Some (eq,u,eq_args) ->
!intro_decomp_eq_function
- (fun n -> tac ((dloc,id)::thin) (Some (true,n)) l)
+ (fun n -> tac ((Loc.tag id)::thin) (Some (true,n)) l)
(eq,t,eq_args) (c, t)
| None ->
Tacticals.New.tclZEROMSG (str "Not a primitive equality here.")
end }
-let intro_or_and_pattern loc with_evars bracketed ll thin tac id =
+let intro_or_and_pattern ?loc with_evars bracketed ll thin tac id =
Proofview.Goal.enter { enter = begin fun gl ->
let c = mkVar id in
let t = Tacmach.New.pf_unsafe_type_of gl c in
@@ -2326,7 +2324,7 @@ let intro_or_and_pattern loc with_evars bracketed ll thin tac id =
let branchsigns = compute_constructor_signatures false ind in
let nv_with_let = Array.map List.length branchsigns in
let ll = fix_empty_or_and_pattern (Array.length branchsigns) ll in
- let ll = get_and_check_or_and_pattern loc ll branchsigns in
+ let ll = get_and_check_or_and_pattern ?loc ll branchsigns in
Tacticals.New.tclTHENLASTn
(Tacticals.New.tclTHEN (simplest_ecase c) (clear [id]))
(Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l)
@@ -2375,8 +2373,8 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac =
Tacticals.New.tclTHENFIRST eqtac (tac thin)
end }
-let prepare_naming loc = function
- | IntroIdentifier id -> NamingMustBe (loc,id)
+let prepare_naming ?loc = function
+ | IntroIdentifier id -> NamingMustBe (Loc.tag ?loc id)
| IntroAnonymous -> NamingAvoid []
| IntroFresh id -> NamingBasedOn (id,[])
@@ -2400,10 +2398,10 @@ let rec check_name_unicity env ok seen = function
| (loc, IntroNaming (IntroIdentifier id)) :: l ->
(try
ignore (if List.mem_f Id.equal id ok then raise Not_found else lookup_named id env);
- user_err ~loc (pr_id id ++ str" is already used.")
+ user_err ?loc (pr_id id ++ str" is already used.")
with Not_found ->
if List.mem_f Id.equal id seen then
- user_err ~loc (pr_id id ++ str" is used twice.")
+ user_err ?loc (pr_id id ++ str" is used twice.")
else
check_name_unicity env ok (id::seen) l)
| (_, IntroAction (IntroOrAndPattern l)) :: l' ->
@@ -2441,7 +2439,7 @@ let make_tmp_naming avoid l = function
case of IntroFresh, we should use check_thin_clash_then anyway to
prevent the case of an IntroFresh precisely using the wild_id *)
| IntroWildcard -> NamingBasedOn (wild_id,avoid@explicit_intro_names l)
- | pat -> NamingAvoid(avoid@explicit_intro_names ((dloc,IntroAction pat)::l))
+ | pat -> NamingAvoid(avoid@explicit_intro_names ((Loc.tag @@ IntroAction pat)::l))
let fit_bound n = function
| None -> true
@@ -2477,7 +2475,7 @@ let rec intro_patterns_core with_evars b avoid ids thin destopt bound n tac =
| [] ->
(* Behave as IntroAnonymous *)
intro_patterns_core with_evars b avoid ids thin destopt bound n tac
- [dloc,IntroNaming IntroAnonymous]
+ [Loc.tag @@ IntroNaming IntroAnonymous]
| (loc,pat) :: l ->
if exceed_bound n bound then error_unexpected_extra_pattern loc bound pat else
match pat with
@@ -2489,7 +2487,7 @@ let rec intro_patterns_core with_evars b avoid ids thin destopt bound n tac =
| IntroAction pat ->
intro_then_gen (make_tmp_naming avoid l pat)
destopt true false
- (intro_pattern_action loc with_evars (b || not (List.is_empty l)) false
+ (intro_pattern_action ?loc with_evars (b || not (List.is_empty l)) false
pat thin destopt
(fun thin bound' -> intro_patterns_core with_evars b avoid ids thin destopt bound' 0
(fun ids thin ->
@@ -2514,21 +2512,21 @@ and intro_pattern_naming loc with_evars b avoid ids pat thin destopt bound n tac
destopt true false
(fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l)
-and intro_pattern_action loc with_evars b style pat thin destopt tac id =
+and intro_pattern_action ?loc with_evars b style pat thin destopt tac id =
match pat with
| IntroWildcard ->
- tac ((loc,id)::thin) None []
+ tac ((Loc.tag ?loc id)::thin) None []
| IntroOrAndPattern ll ->
- intro_or_and_pattern loc with_evars b ll thin tac id
+ intro_or_and_pattern ?loc with_evars b ll thin tac id
| IntroInjection l' ->
- intro_decomp_eq loc l' thin tac id
+ intro_decomp_eq ?loc l' thin tac id
| IntroRewrite l2r ->
rewrite_hyp_then style with_evars thin l2r id (fun thin -> tac thin None [])
| IntroApplyOn ((loc',f),(loc,pat)) ->
let naming,tac_ipat =
- prepare_intros_loc loc with_evars (IntroIdentifier id) destopt pat in
+ prepare_intros ?loc with_evars (IntroIdentifier id) destopt pat in
let doclear =
- if naming = NamingMustBe (loc,id) then
+ if naming = NamingMustBe (Loc.tag ?loc id) then
Proofview.tclUNIT () (* apply_in_once do a replacement *)
else
clear [id] in
@@ -2539,18 +2537,18 @@ and intro_pattern_action loc with_evars b style pat thin destopt tac id =
apply_in_delayed_once false true true with_evars naming id (None,(loc',f))
(fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []])
-and prepare_intros_loc loc with_evars dft destopt = function
+and prepare_intros ?loc with_evars dft destopt = function
| IntroNaming ipat ->
- prepare_naming loc ipat,
+ prepare_naming ?loc ipat,
(fun id -> move_hyp id destopt)
| IntroAction ipat ->
- prepare_naming loc dft,
+ prepare_naming ?loc dft,
(let tac thin bound =
intro_patterns_core with_evars true [] [] thin destopt bound 0
(fun _ l -> clear_wildcards l) in
fun id ->
- intro_pattern_action loc with_evars true true ipat [] destopt tac id)
- | IntroForthcoming _ -> user_err ~loc
+ intro_pattern_action ?loc with_evars true true ipat [] destopt tac id)
+ | IntroForthcoming _ -> user_err ?loc
(str "Introduction pattern for one hypothesis expected.")
let intro_patterns_head_core with_evars b destopt bound pat =
@@ -2570,7 +2568,7 @@ let intro_patterns_to with_evars destopt =
destopt None
let intro_pattern_to with_evars destopt pat =
- intro_patterns_to with_evars destopt [dloc,pat]
+ intro_patterns_to with_evars destopt [Loc.tag pat]
let intro_patterns with_evars = intro_patterns_to with_evars MoveLast
@@ -2583,20 +2581,20 @@ let intros_patterns with_evars = function
(* Forward reasoning *)
(**************************)
-let prepare_intros with_evars dft destopt = function
- | None -> prepare_naming dloc dft, (fun _id -> Proofview.tclUNIT ())
- | Some (loc,ipat) -> prepare_intros_loc loc with_evars dft destopt ipat
+let prepare_intros_opt with_evars dft destopt = function
+ | None -> prepare_naming dft, (fun _id -> Proofview.tclUNIT ())
+ | Some (loc,ipat) -> prepare_intros ?loc with_evars dft destopt ipat
let ipat_of_name = function
| Anonymous -> None
- | Name id -> Some (dloc, IntroNaming (IntroIdentifier id))
+ | Name id -> Some (Loc.tag @@ IntroNaming (IntroIdentifier id))
let head_ident sigma c =
let c = fst (decompose_app sigma (snd (decompose_lam_assum sigma c))) in
if isVar sigma c then Some (destVar sigma c) else None
let assert_as first hd ipat t =
- let naming,tac = prepare_intros false IntroAnonymous MoveLast ipat in
+ let naming,tac = prepare_intros_opt false IntroAnonymous MoveLast ipat in
let repl = do_replace hd naming in
let tac = if repl then (fun id -> Proofview.tclUNIT ()) else tac in
if first then assert_before_then_gen repl naming t tac
@@ -2614,10 +2612,10 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars
if with_evars then MoveLast (* evars would depend on the whole context *)
else get_previous_hyp_position id gl in
let naming,ipat_tac =
- prepare_intros with_evars (IntroIdentifier id) destopt ipat in
+ prepare_intros_opt with_evars (IntroIdentifier id) destopt ipat in
let lemmas_target, last_lemma_target =
let last,first = List.sep_last lemmas in
- List.map (fun lem -> (NamingMustBe (dloc,id),lem)) first, (naming,last)
+ List.map (fun lem -> (NamingMustBe (Loc.tag id),lem)) first, (naming,last)
in
(* We chain apply_in_once, ending with an intro pattern *)
List.fold_right tac lemmas_target (tac last_lemma_target ipat_tac) id
@@ -2695,7 +2693,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty =
let tac =
Tacticals.New.tclTHENLIST
[ convert_concl_no_check newcl DEFAULTcast;
- intro_gen (NamingMustBe (dloc,id)) (decode_hyp lastlhyp) true false;
+ intro_gen (NamingMustBe (Loc.tag id)) (decode_hyp lastlhyp) true false;
Tacticals.New.tclMAP convert_hyp_no_check depdecls;
eq_tac ]
in
@@ -2728,7 +2726,7 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty =
| IntroFresh heq_base -> fresh_id_in_env [id] heq_base env
| IntroIdentifier id ->
if List.mem id (ids_of_named_context (named_context env)) then
- user_err ~loc (pr_id id ++ str" is already used.");
+ user_err ?loc (pr_id id ++ str" is already used.");
id in
let eqdata = build_coq_eq_data () in
let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in
@@ -2992,7 +2990,7 @@ let specialize (c,lbind) ipat =
| Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) ->
(* Like assert (id:=id args) but with the concept of specialization *)
let naming,tac =
- prepare_intros false (IntroIdentifier id) MoveLast ipat in
+ prepare_intros_opt false (IntroIdentifier id) MoveLast ipat in
let repl = do_replace (Some id) naming in
Tacticals.New.tclTHENFIRST
(assert_before_then_gen repl naming typ tac)
@@ -3006,7 +3004,7 @@ let specialize (c,lbind) ipat =
| Some (loc,ipat) ->
(* Like pose proof with extra support for "with" bindings *)
(* even though the "with" bindings forces full application *)
- let naming,tac = prepare_intros_loc loc false IntroAnonymous MoveLast ipat in
+ let naming,tac = prepare_intros ?loc false IntroAnonymous MoveLast ipat in
Tacticals.New.tclTHENFIRST
(assert_before_then_gen false naming typ tac)
(exact_no_check term)
@@ -3094,7 +3092,7 @@ let intropattern_of_name gl avoid = function
| Name id -> IntroNaming (IntroIdentifier (new_fresh_id avoid id gl))
let rec consume_pattern avoid na isdep gl = function
- | [] -> ((dloc, intropattern_of_name gl avoid na), [])
+ | [] -> ((Loc.tag @@ intropattern_of_name gl avoid na), [])
| (loc,IntroForthcoming true)::names when not isdep ->
consume_pattern avoid na isdep gl names
| (loc,IntroForthcoming _)::names as fullpat ->
@@ -3171,7 +3169,7 @@ let induct_discharge with_evars dests avoid' tac (avoid,ra) names =
let (recpat,names) = match names with
| [loc,IntroNaming (IntroIdentifier id) as pat] ->
let id' = next_ident_away (add_prefix "IH" id) avoid in
- (pat, [dloc, IntroNaming (IntroIdentifier id')])
+ (pat, [Loc.tag @@ IntroNaming (IntroIdentifier id')])
| _ -> consume_pattern avoid (Name recvarname) deprec gl names in
let dest = get_recarg_dest dests in
dest_intro_patterns with_evars avoid thin dest [recpat] (fun ids thin ->
@@ -4501,7 +4499,7 @@ let induction_gen_l isrec with_evars elim names lc =
let lc = List.map (function
| (c,None) -> c
| (c,Some(loc,eqname)) ->
- user_err ~loc (str "Do not know what to do with " ++
+ user_err ?loc (str "Do not know what to do with " ++
Miscprint.pr_intro_pattern_naming eqname)) lc in
let rec atomize_list l =
match l with
@@ -5068,14 +5066,14 @@ module Simple = struct
let intro x = intro_move (Some x) MoveLast
let apply c =
- apply_with_bindings_gen false false [None,(Loc.ghost,(c,NoBindings))]
+ apply_with_bindings_gen false false [None,(Loc.tag (c,NoBindings))]
let eapply c =
- apply_with_bindings_gen false true [None,(Loc.ghost,(c,NoBindings))]
+ apply_with_bindings_gen false true [None,(Loc.tag (c,NoBindings))]
let elim c = elim false None (c,NoBindings) None
let case c = general_case_analysis false None (c,NoBindings)
let apply_in id c =
- apply_in false false id [None,(Loc.ghost, (c, NoBindings))] None
+ apply_in false false id [None,(Loc.tag (c, NoBindings))] None
end
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-05 02:57:21 +0000