aboutsummaryrefslogtreecommitdiff
path: root/plugins/ltac
diff options
context:
space:
mode:
Diffstat (limited to 'plugins/ltac')
-rw-r--r--plugins/ltac/coretactics.ml42
-rw-r--r--plugins/ltac/extraargs.ml42
-rw-r--r--plugins/ltac/extratactics.ml481
-rw-r--r--plugins/ltac/g_auto.ml42
-rw-r--r--plugins/ltac/g_class.ml42
-rw-r--r--plugins/ltac/g_eqdecide.ml42
-rw-r--r--plugins/ltac/g_ltac.ml421
-rw-r--r--plugins/ltac/g_obligations.ml44
-rw-r--r--plugins/ltac/g_rewrite.ml42
-rw-r--r--plugins/ltac/g_tactic.ml46
-rw-r--r--plugins/ltac/pptactic.ml195
-rw-r--r--plugins/ltac/pptactic.mli25
-rw-r--r--plugins/ltac/profile_ltac.ml31
-rw-r--r--plugins/ltac/profile_ltac.mli37
-rw-r--r--plugins/ltac/profile_ltac_tactics.ml442
-rw-r--r--plugins/ltac/rewrite.ml49
-rw-r--r--plugins/ltac/taccoerce.ml20
-rw-r--r--plugins/ltac/taccoerce.mli3
-rw-r--r--plugins/ltac/tacentries.ml3
-rw-r--r--plugins/ltac/tacexpr.mli2
-rw-r--r--plugins/ltac/tacintern.ml4
-rw-r--r--plugins/ltac/tacinterp.ml92
-rw-r--r--plugins/ltac/tacsubst.ml2
-rw-r--r--plugins/ltac/tactic_matching.ml4
24 files changed, 397 insertions, 236 deletions
diff --git a/plugins/ltac/coretactics.ml4 b/plugins/ltac/coretactics.ml4
index 2769802cf4..7d2c4d0825 100644
--- a/plugins/ltac/coretactics.ml4
+++ b/plugins/ltac/coretactics.ml4
@@ -6,8 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
open Util
open Locus
open Misctypes
diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4
index bb01aca558..4c6d3c2d36 100644
--- a/plugins/ltac/extraargs.ml4
+++ b/plugins/ltac/extraargs.ml4
@@ -6,8 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
open Pp
open Genarg
open Stdarg
diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4
index 982fc7cc3c..286f9d95d5 100644
--- a/plugins/ltac/extratactics.ml4
+++ b/plugins/ltac/extratactics.ml4
@@ -6,8 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
open Pp
open Genarg
open Stdarg
@@ -25,6 +23,7 @@ open Termops
open Equality
open Misctypes
open Proofview.Notations
+open Vernacinterp
DECLARE PLUGIN "ltac_plugin"
@@ -249,11 +248,10 @@ TACTIC EXTEND rewrite_star
(**********************************************************************)
(* Hint Rewrite *)
-let add_rewrite_hint bases ort t lcsr =
+let add_rewrite_hint ~poly bases ort t lcsr =
let env = Global.env() in
let sigma = Evd.from_env env in
- let poly = Flags.use_polymorphic_flag () in
- let f ce =
+ let f ce =
let c, ctx = Constrintern.interp_constr env sigma ce in
let ctx =
let ctx = UState.context_set ctx in
@@ -270,16 +268,16 @@ let add_rewrite_hint bases ort t lcsr =
let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater
-VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY classify_hint
+VERNAC COMMAND FUNCTIONAL EXTEND HintRewrite CLASSIFIED BY classify_hint
[ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] ->
- [ add_rewrite_hint bl o None l ]
+ [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic bl o None l; st ]
| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t)
":" preident_list(bl) ] ->
- [ add_rewrite_hint bl o (Some t) l ]
+ [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic bl o (Some t) l; st ]
| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] ->
- [ add_rewrite_hint ["core"] o None l ]
+ [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic ["core"] o None l; st ]
| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] ->
- [ add_rewrite_hint ["core"] o (Some t) l ]
+ [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic ["core"] o (Some t) l; st ]
END
(**********************************************************************)
@@ -290,7 +288,7 @@ open EConstr
open Vars
open Coqlib
-let project_hint pri l2r r =
+let project_hint ~poly pri l2r r =
let gr = Smartlocate.global_with_alias r in
let env = Global.env() in
let sigma = Evd.from_env env in
@@ -313,30 +311,28 @@ let project_hint pri l2r r =
let id =
Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l"))
in
- let poly = Flags.use_polymorphic_flag () in
let ctx = Evd.const_univ_entry ~poly sigma in
let c = EConstr.to_constr sigma c in
let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in
let info = {Vernacexpr.hint_priority = pri; hint_pattern = None} in
(info,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c))
-let add_hints_iff ?locality l2r lc n bl =
- Hints.add_hints (Locality.make_module_locality locality) bl
- (Hints.HintsResolveEntry (List.map (project_hint n l2r) lc))
+let add_hints_iff ~atts l2r lc n bl =
+ let open Vernacinterp in
+ Hints.add_hints (Locality.make_module_locality atts.locality) bl
+ (Hints.HintsResolveEntry (List.map (project_hint ~poly:atts.polymorphic n l2r) lc))
VERNAC COMMAND FUNCTIONAL EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF
[ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n)
":" preident_list(bl) ] ->
[ fun ~atts ~st -> begin
- let open Vernacinterp in
- add_hints_iff ?locality:atts.locality true lc n bl;
+ add_hints_iff ~atts true lc n bl;
st
end
]
| [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ] ->
[ fun ~atts ~st -> begin
- let open Vernacinterp in
- add_hints_iff ?locality:atts.locality true lc n ["core"];
+ add_hints_iff ~atts true lc n ["core"];
st
end
]
@@ -346,15 +342,13 @@ VERNAC COMMAND FUNCTIONAL EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF
[ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n)
":" preident_list(bl) ] ->
[ fun ~atts ~st -> begin
- let open Vernacinterp in
- add_hints_iff ?locality:atts.locality false lc n bl;
+ add_hints_iff ~atts false lc n bl;
st
end
]
| [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ] ->
[ fun ~atts ~st -> begin
- let open Vernacinterp in
- add_hints_iff ?locality:atts.locality false lc n ["core"];
+ add_hints_iff ~atts false lc n ["core"];
st
end
]
@@ -430,34 +424,46 @@ let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater
| [ "Type" ] -> [ InType ]
END*)
-VERNAC COMMAND EXTEND DeriveInversionClear
+VERNAC COMMAND FUNCTIONAL EXTEND DeriveInversionClear
| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ]
=> [ seff na ]
- -> [ add_inversion_lemma_exn na c s false inv_clear_tac ]
+ -> [ fun ~atts ~st ->
+ let open Vernacinterp in
+ add_inversion_lemma_exn ~poly:atts.polymorphic na c s false inv_clear_tac; st ]
| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ]
- -> [ add_inversion_lemma_exn na c Sorts.InProp false inv_clear_tac ]
+ -> [ fun ~atts ~st ->
+ let open Vernacinterp in
+ add_inversion_lemma_exn ~poly:atts.polymorphic na c Sorts.InProp false inv_clear_tac; st ]
END
-VERNAC COMMAND EXTEND DeriveInversion
+VERNAC COMMAND FUNCTIONAL EXTEND DeriveInversion
| [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ]
=> [ seff na ]
- -> [ add_inversion_lemma_exn na c s false inv_tac ]
+ -> [ fun ~atts ~st ->
+ let open Vernacinterp in
+ add_inversion_lemma_exn ~poly:atts.polymorphic na c s false inv_tac; st ]
| [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ]
- -> [ add_inversion_lemma_exn na c Sorts.InProp false inv_tac ]
+ -> [ fun ~atts ~st ->
+ let open Vernacinterp in
+ add_inversion_lemma_exn ~poly:atts.polymorphic na c Sorts.InProp false inv_tac; st ]
END
-VERNAC COMMAND EXTEND DeriveDependentInversion
+VERNAC COMMAND FUNCTIONAL EXTEND DeriveDependentInversion
| [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ]
=> [ seff na ]
- -> [ add_inversion_lemma_exn na c s true dinv_tac ]
+ -> [ fun ~atts ~st ->
+ let open Vernacinterp in
+ add_inversion_lemma_exn ~poly:atts.polymorphic na c s true dinv_tac; st ]
END
-VERNAC COMMAND EXTEND DeriveDependentInversionClear
+VERNAC COMMAND FUNCTIONAL EXTEND DeriveDependentInversionClear
| [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ]
=> [ seff na ]
- -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ]
+ -> [ fun ~atts ~st ->
+ let open Vernacinterp in
+ add_inversion_lemma_exn ~poly:atts.polymorphic na c s true dinv_clear_tac; st ]
END
(**********************************************************************)
@@ -1117,3 +1123,12 @@ VERNAC COMMAND EXTEND OptimizeProof
| [ "Optimize" "Heap" ] => [ Vernac_classifier.classify_as_proofstep ] ->
[ Gc.compact () ]
END
+
+(** tactic analogous to "OPTIMIZE HEAP" *)
+
+let tclOPTIMIZE_HEAP =
+ Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> Gc.compact ()))
+
+TACTIC EXTEND optimize_heap
+| [ "optimize_heap" ] -> [ tclOPTIMIZE_HEAP ]
+END
diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4
index 90a44708fc..f74d24db07 100644
--- a/plugins/ltac/g_auto.ml4
+++ b/plugins/ltac/g_auto.ml4
@@ -6,8 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
open Pp
open Genarg
open Stdarg
diff --git a/plugins/ltac/g_class.ml4 b/plugins/ltac/g_class.ml4
index ed2d9da63a..014433ac47 100644
--- a/plugins/ltac/g_class.ml4
+++ b/plugins/ltac/g_class.ml4
@@ -6,8 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
open Class_tactics
open Stdarg
open Tacarg
diff --git a/plugins/ltac/g_eqdecide.ml4 b/plugins/ltac/g_eqdecide.ml4
index 5494369022..f705778fc0 100644
--- a/plugins/ltac/g_eqdecide.ml4
+++ b/plugins/ltac/g_eqdecide.ml4
@@ -12,8 +12,6 @@
(* by Eduardo Gimenez *)
(************************************************************************)
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
open Eqdecide
DECLARE PLUGIN "ltac_plugin"
diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4
index 34fea6175b..9ef8195695 100644
--- a/plugins/ltac/g_ltac.ml4
+++ b/plugins/ltac/g_ltac.ml4
@@ -6,8 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
DECLARE PLUGIN "ltac_plugin"
open Util
@@ -17,7 +15,7 @@ open Tacexpr
open Misctypes
open Genarg
open Genredexpr
-open Tok (* necessary for camlp4 *)
+open Tok (* necessary for camlp5 *)
open Names
open Pcoq
@@ -78,11 +76,6 @@ let test_bracket_ident =
let hint = G_proofs.hint
-let warn_deprecated_appcontext =
- CWarnings.create ~name:"deprecated-appcontext" ~category:"deprecated"
- (fun () -> strbrk "appcontext is deprecated and will be removed " ++
- strbrk "in a future version")
-
GEXTEND Gram
GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg command hint
tactic_mode constr_may_eval constr_eval toplevel_selector
@@ -242,12 +235,7 @@ GEXTEND Gram
match_pattern:
[ [ IDENT "context"; oid = OPT Constr.ident;
"["; pc = Constr.lconstr_pattern; "]" ->
- let mode = not (!Flags.tactic_context_compat) in
- Subterm (mode, oid, pc)
- | IDENT "appcontext"; oid = OPT Constr.ident;
- "["; pc = Constr.lconstr_pattern; "]" ->
- warn_deprecated_appcontext ~loc:!@loc ();
- Subterm (true,oid, pc)
+ Subterm (oid, pc)
| pc = Constr.lconstr_pattern -> Term pc ] ]
;
match_hyps:
@@ -337,7 +325,8 @@ GEXTEND Gram
| IDENT "all"; ":" -> SelectAll ] ]
;
tactic_mode:
- [ [ g = OPT toplevel_selector; tac = G_vernac.query_command -> tac g ] ]
+ [ [ g = OPT toplevel_selector; tac = G_vernac.query_command -> tac g
+ | g = OPT toplevel_selector; "{" -> Vernacexpr.VernacSubproof g ] ]
;
command:
[ [ IDENT "Proof"; "with"; ta = Pltac.tactic;
@@ -471,7 +460,7 @@ END
VERNAC COMMAND FUNCTIONAL EXTEND VernacTacticNotation
| [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] =>
- [ VtUnknown, VtNow ] ->
+ [ VtSideff [], VtNow ] ->
[ fun ~atts ~st -> let open Vernacinterp in
let n = Option.default 0 n in
Tacentries.add_tactic_notation (Locality.make_module_locality atts.locality) n r e;
diff --git a/plugins/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.ml4
index f6cc3833a7..e251b10495 100644
--- a/plugins/ltac/g_obligations.ml4
+++ b/plugins/ltac/g_obligations.ml4
@@ -6,11 +6,9 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
(*
Syntax for the subtac terms and types.
- Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *)
+ Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *)
open Libnames
open Constrexpr
diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4
index ea1808a255..2459a09bc6 100644
--- a/plugins/ltac/g_rewrite.ml4
+++ b/plugins/ltac/g_rewrite.ml4
@@ -6,8 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
(* Syntax for rewriting with strategies *)
open Names
diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4
index d792d4ff7d..e68140828a 100644
--- a/plugins/ltac/g_tactic.ml4
+++ b/plugins/ltac/g_tactic.ml4
@@ -115,10 +115,11 @@ let mk_fix_tac (loc,id,bl,ann,ty) =
match bl,ann with
[([_],_,_)], None -> 1
| _, Some x ->
- let ids = List.map snd (List.flatten (List.map pi1 bl)) in
+ let ids = List.map snd (List.flatten (List.map (fun (nal,_,_) -> nal) bl)) in
(try List.index Names.Name.equal (snd x) ids
with Not_found -> user_err Pp.(str "No such fix variable."))
| _ -> user_err Pp.(str "Cannot guess decreasing argument of fix.") in
+ let bl = List.map (fun (nal,bk,t) -> CLocalAssum (nal,bk,t)) bl in
(id,n, CAst.make ~loc @@ CProdN(bl,ty))
let mk_cofix_tac (loc,id,bl,ann,ty) =
@@ -126,6 +127,7 @@ let mk_cofix_tac (loc,id,bl,ann,ty) =
user_err ~loc:aloc
~hdr:"Constr:mk_cofix_tac"
(Pp.str"Annotation forbidden in cofix expression.")) ann in
+ let bl = List.map (fun (nal,bk,t) -> CLocalAssum (nal,bk,t)) bl in
(id,CAst.make ~loc @@ CProdN(bl,ty))
(* Functions overloaded by quotifier *)
@@ -160,7 +162,7 @@ let mkTacCase with_evar = function
let rec mkCLambdaN_simple_loc ?loc bll c =
match bll with
| ((loc1,_)::_ as idl,bk,t) :: bll ->
- CAst.make ?loc @@ CLambdaN ([idl,bk,t],mkCLambdaN_simple_loc ?loc:(Loc.merge_opt loc1 loc) bll c)
+ CAst.make ?loc @@ CLambdaN ([CLocalAssum (idl,bk,t)],mkCLambdaN_simple_loc ?loc:(Loc.merge_opt loc1 loc) bll c)
| ([],_,_) :: bll -> mkCLambdaN_simple_loc ?loc bll c
| [] -> c
diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml
index d707512457..4f430b79e4 100644
--- a/plugins/ltac/pptactic.ml
+++ b/plugins/ltac/pptactic.ml
@@ -84,6 +84,24 @@ type 'a extra_genarg_printer =
(tolerability -> Val.t -> Pp.t) ->
'a -> Pp.t
+type 'a raw_extra_genarg_printer_with_level =
+ (constr_expr -> Pp.t) ->
+ (constr_expr -> Pp.t) ->
+ (tolerability -> raw_tactic_expr -> Pp.t) ->
+ tolerability -> 'a -> Pp.t
+
+type 'a glob_extra_genarg_printer_with_level =
+ (glob_constr_and_expr -> Pp.t) ->
+ (glob_constr_and_expr -> Pp.t) ->
+ (tolerability -> glob_tactic_expr -> Pp.t) ->
+ tolerability -> 'a -> Pp.t
+
+type 'a extra_genarg_printer_with_level =
+ (EConstr.constr -> Pp.t) ->
+ (EConstr.constr -> Pp.t) ->
+ (tolerability -> Val.t -> Pp.t) ->
+ tolerability -> 'a -> Pp.t
+
let string_of_genarg_arg (ArgumentType arg) =
let rec aux : type a b c. (a, b, c) genarg_type -> string = function
| ListArg t -> aux t ^ "_list"
@@ -127,9 +145,9 @@ let string_of_genarg_arg (ArgumentType arg) =
| Some Refl ->
let open Genprint in
match generic_top_print (in_gen (Topwit wit) x) with
- | PrinterBasic pr -> pr ()
- | PrinterNeedsContext pr -> pr (Global.env()) Evd.empty
- | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } ->
+ | TopPrinterBasic pr -> pr ()
+ | TopPrinterNeedsContext pr -> pr (Global.env()) Evd.empty
+ | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } ->
printer (Global.env()) Evd.empty default_ensure_surrounded
end
| _ -> default
@@ -335,9 +353,10 @@ let string_of_genarg_arg (ArgumentType arg) =
let rec strip_ty acc n ty =
match ty.CAst.v with
Constrexpr.CProdN(bll,a) ->
- let nb =
- List.fold_left (fun i (nal,_,_) -> i + List.length nal) 0 bll in
- let bll = List.map (fun (x, _, y) -> x, y) bll in
+ let bll = List.map (function
+ | CLocalAssum (nal,_,t) -> nal,t
+ | _ -> user_err Pp.(str "Cannot translate fix tactic: not only products")) bll in
+ let nb = List.fold_left (fun i (nal,t) -> i + List.length nal) 0 bll in
if nb >= n then (List.rev (bll@acc)), a
else strip_ty (bll@acc) (n-nb) a
| _ -> user_err Pp.(str "Cannot translate fix tactic: not enough products") in
@@ -508,11 +527,9 @@ let pr_goal_selector ~toplevel s =
let pr_match_pattern pr_pat = function
| Term a -> pr_pat a
- | Subterm (b,None,a) ->
- (** ppedrot: we don't make difference between [appcontext] and [context]
- anymore, and the interpretation is governed by a flag instead. *)
+ | Subterm (None,a) ->
keyword "context" ++ str" [ " ++ pr_pat a ++ str " ]"
- | Subterm (b,Some id,a) ->
+ | Subterm (Some id,a) ->
keyword "context" ++ spc () ++ pr_id id ++ str "[ " ++ pr_pat a ++ str " ]"
let pr_match_hyps pr_pat = function
@@ -723,8 +740,10 @@ let pr_goal_selector ~toplevel s =
| TacIntroPattern (ev,[]) as t ->
pr_atom0 t
| TacIntroPattern (ev,(_::_ as p)) ->
- hov 1 (primitive (if ev then "eintros" else "intros") ++ spc () ++
- prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p)
+ hov 1 (primitive (if ev then "eintros" else "intros") ++
+ (match p with
+ | [_,Misctypes.IntroForthcoming false] -> mt ()
+ | _ -> spc () ++ prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p))
| TacApply (a,ev,cb,inhyp) ->
hov 1 (
(if a then mt() else primitive "simple ") ++
@@ -1192,42 +1211,77 @@ let declare_extra_genarg_pprule wit
| ExtraArg s -> ()
| _ -> user_err Pp.(str "Can declare a pretty-printing rule only for extra argument types.")
end;
- let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in
+ let f x =
+ Genprint.PrinterBasic (fun () ->
+ f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in
let g x =
+ Genprint.PrinterBasic (fun () ->
let env = Global.env () in
- g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x
+ g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x)
in
let h x =
- Genprint.PrinterNeedsContext (fun env sigma ->
+ Genprint.TopPrinterNeedsContext (fun env sigma ->
h (pr_econstr_env env sigma) (pr_leconstr_env env sigma) (fun _ _ -> str "<tactic>") x)
in
Genprint.register_print0 wit f g h
+let declare_extra_genarg_pprule_with_level wit
+ (f : 'a raw_extra_genarg_printer_with_level)
+ (g : 'b glob_extra_genarg_printer_with_level)
+ (h : 'c extra_genarg_printer_with_level) default_surrounded default_non_surrounded =
+ begin match wit with
+ | ExtraArg s -> ()
+ | _ -> user_err Pp.(str "Can declare a pretty-printing rule only for extra argument types.")
+ end;
+ let open Genprint in
+ let f x =
+ PrinterNeedsLevel {
+ default_already_surrounded = default_surrounded;
+ default_ensure_surrounded = default_non_surrounded;
+ printer = (fun n ->
+ f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level n x) } in
+ let g x =
+ let env = Global.env () in
+ PrinterNeedsLevel {
+ default_already_surrounded = default_surrounded;
+ default_ensure_surrounded = default_non_surrounded;
+ printer = (fun n ->
+ g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) n x) }
+ in
+ let h x =
+ TopPrinterNeedsContextAndLevel {
+ default_already_surrounded = default_surrounded;
+ default_ensure_surrounded = default_non_surrounded;
+ printer = (fun env sigma n ->
+ h (pr_econstr_env env sigma) (pr_leconstr_env env sigma) (fun _ _ -> str "<tactic>") n x) }
+ in
+ Genprint.register_print0 wit f g h
+
let declare_extra_vernac_genarg_pprule wit f =
- let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in
+ let f x = Genprint.PrinterBasic (fun () -> f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in
Genprint.register_vernac_print0 wit f
(** Registering *)
-let pr_intro_pattern_env p = Genprint.PrinterNeedsContext (fun env sigma ->
+let pr_intro_pattern_env p = Genprint.TopPrinterNeedsContext (fun env sigma ->
let print_constr c = let (sigma, c) = c env sigma in pr_econstr_env env sigma c in
Miscprint.pr_intro_pattern print_constr p)
-let pr_red_expr_env r = Genprint.PrinterNeedsContext (fun env sigma ->
+let pr_red_expr_env r = Genprint.TopPrinterNeedsContext (fun env sigma ->
pr_red_expr (pr_econstr_env env sigma, pr_leconstr_env env sigma,
pr_evaluable_reference_env env, pr_constr_pattern_env env sigma) r)
-let pr_bindings_env bl = Genprint.PrinterNeedsContext (fun env sigma ->
+let pr_bindings_env bl = Genprint.TopPrinterNeedsContext (fun env sigma ->
let sigma, bl = bl env sigma in
Miscprint.pr_bindings
(pr_econstr_env env sigma) (pr_leconstr_env env sigma) bl)
-let pr_with_bindings_env bl = Genprint.PrinterNeedsContext (fun env sigma ->
+let pr_with_bindings_env bl = Genprint.TopPrinterNeedsContext (fun env sigma ->
let sigma, bl = bl env sigma in
pr_with_bindings
(pr_econstr_env env sigma) (pr_leconstr_env env sigma) bl)
-let pr_destruction_arg_env c = Genprint.PrinterNeedsContext (fun env sigma ->
+let pr_destruction_arg_env c = Genprint.TopPrinterNeedsContext (fun env sigma ->
let sigma, c = match c with
| clear_flag,ElimOnConstr g -> let sigma,c = g env sigma in sigma,(clear_flag,ElimOnConstr c)
| clear_flag,ElimOnAnonHyp n as x -> sigma, x
@@ -1236,12 +1290,16 @@ let pr_destruction_arg_env c = Genprint.PrinterNeedsContext (fun env sigma ->
(pr_econstr_env env sigma) (pr_leconstr_env env sigma) c)
let make_constr_printer f c =
- Genprint.PrinterNeedsContextAndLevel {
+ Genprint.TopPrinterNeedsContextAndLevel {
Genprint.default_already_surrounded = Ppconstr.ltop;
Genprint.default_ensure_surrounded = Ppconstr.lsimpleconstr;
Genprint.printer = (fun env sigma n -> f env sigma n c)}
let lift f a = Genprint.PrinterBasic (fun () -> f a)
+let lift_top f a = Genprint.TopPrinterBasic (fun () -> f a)
+
+let register_basic_print0 wit f g h =
+ Genprint.register_print0 wit (lift f) (lift g) (lift_top h)
let pr_glob_constr_pptac c =
@@ -1255,80 +1313,81 @@ let pr_lglob_constr_pptac c =
let () =
let pr_bool b = if b then str "true" else str "false" in
let pr_unit _ = str "()" in
- Genprint.register_print0 wit_int_or_var
- (pr_or_var int) (pr_or_var int) (lift int);
- Genprint.register_print0 wit_ref
- pr_reference (pr_or_var (pr_located pr_global)) (lift pr_global);
- Genprint.register_print0 wit_ident
- pr_id pr_id (lift pr_id);
- Genprint.register_print0 wit_var
- (pr_located pr_id) (pr_located pr_id) (lift pr_id);
- Genprint.register_print0
+ let open Genprint in
+ register_basic_print0 wit_int_or_var (pr_or_var int) (pr_or_var int) int;
+ register_basic_print0 wit_ref
+ pr_reference (pr_or_var (pr_located pr_global)) pr_global;
+ register_basic_print0 wit_ident pr_id pr_id pr_id;
+ register_basic_print0 wit_var (pr_located pr_id) (pr_located pr_id) pr_id;
+ register_print0
wit_intro_pattern
- (Miscprint.pr_intro_pattern pr_constr_expr)
- (Miscprint.pr_intro_pattern (fun (c, _) -> pr_glob_constr_pptac c))
+ (lift (Miscprint.pr_intro_pattern pr_constr_expr))
+ (lift (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr_pptac c)))
pr_intro_pattern_env;
Genprint.register_print0
wit_clause_dft_concl
- (pr_clauses (Some true) pr_lident)
- (pr_clauses (Some true) pr_lident)
- (fun c -> Genprint.PrinterBasic (fun () -> pr_clauses (Some true) (fun id -> pr_lident (Loc.tag id)) c))
+ (lift (pr_clauses (Some true) pr_lident))
+ (lift (pr_clauses (Some true) pr_lident))
+ (fun c -> Genprint.TopPrinterBasic (fun () -> pr_clauses (Some true) (fun id -> pr_lident (Loc.tag id)) c))
;
Genprint.register_print0
wit_constr
- Ppconstr.pr_constr_expr
- (fun (c, _) -> pr_glob_constr_pptac c)
+ (lift Ppconstr.pr_lconstr_expr)
+ (lift (fun (c, _) -> pr_lglob_constr_pptac c))
(make_constr_printer Printer.pr_econstr_n_env)
;
Genprint.register_print0
wit_uconstr
- Ppconstr.pr_constr_expr
- (fun (c, _) -> pr_glob_constr_pptac c)
+ (lift Ppconstr.pr_constr_expr)
+ (lift (fun (c,_) -> pr_glob_constr_pptac c))
(make_constr_printer Printer.pr_closed_glob_n_env)
;
Genprint.register_print0
wit_open_constr
- Ppconstr.pr_constr_expr
- (fun (c, _) -> pr_glob_constr_pptac c)
+ (lift Ppconstr.pr_constr_expr)
+ (lift (fun (c, _) -> pr_glob_constr_pptac c))
(make_constr_printer Printer.pr_econstr_n_env)
;
- Genprint.register_print0 wit_red_expr
- (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr))
- (pr_red_expr (pr_and_constr_expr pr_glob_constr_pptac, pr_and_constr_expr pr_lglob_constr_pptac, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr_pptac))
+ Genprint.register_print0
+ wit_red_expr
+ (lift (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr)))
+ (lift (pr_red_expr (pr_and_constr_expr pr_glob_constr_pptac, pr_and_constr_expr pr_lglob_constr_pptac, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr_pptac)))
pr_red_expr_env
;
- Genprint.register_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis (lift pr_quantified_hypothesis);
- Genprint.register_print0 wit_bindings
- (Miscprint.pr_bindings_no_with pr_constr_expr pr_lconstr_expr)
- (Miscprint.pr_bindings_no_with (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))
+ register_basic_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis;
+ register_print0 wit_bindings
+ (lift (Miscprint.pr_bindings_no_with pr_constr_expr pr_lconstr_expr))
+ (lift (Miscprint.pr_bindings_no_with (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac)))
pr_bindings_env
;
- Genprint.register_print0 wit_constr_with_bindings
- (pr_with_bindings pr_constr_expr pr_lconstr_expr)
- (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))
+ register_print0 wit_constr_with_bindings
+ (lift (pr_with_bindings pr_constr_expr pr_lconstr_expr))
+ (lift (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac)))
pr_with_bindings_env
;
- Genprint.register_print0 wit_open_constr_with_bindings
- (pr_with_bindings pr_constr_expr pr_lconstr_expr)
- (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))
+ register_print0 wit_open_constr_with_bindings
+ (lift (pr_with_bindings pr_constr_expr pr_lconstr_expr))
+ (lift (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac)))
pr_with_bindings_env
;
- Genprint.register_print0 Tacarg.wit_destruction_arg
- (pr_destruction_arg pr_constr_expr pr_lconstr_expr)
- (pr_destruction_arg (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))
+ register_print0 Tacarg.wit_destruction_arg
+ (lift (pr_destruction_arg pr_constr_expr pr_lconstr_expr))
+ (lift (pr_destruction_arg (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac)))
pr_destruction_arg_env
;
- Genprint.register_print0 Stdarg.wit_int int int (lift int);
- Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool (lift pr_bool);
- Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit (lift pr_unit);
- Genprint.register_print0 Stdarg.wit_pre_ident str str (lift str);
- Genprint.register_print0 Stdarg.wit_string qstring qstring (lift qstring)
+ register_basic_print0 Stdarg.wit_int int int int;
+ register_basic_print0 Stdarg.wit_bool pr_bool pr_bool pr_bool;
+ register_basic_print0 Stdarg.wit_unit pr_unit pr_unit pr_unit;
+ register_basic_print0 Stdarg.wit_pre_ident str str str;
+ register_basic_print0 Stdarg.wit_string qstring qstring qstring
let () =
- let printer _ _ prtac = prtac (0, E) in
- declare_extra_genarg_pprule wit_tactic printer printer printer
+ let printer _ _ prtac = prtac in
+ declare_extra_genarg_pprule_with_level wit_tactic printer printer printer
+ ltop (0,E)
let () =
- let pr_unit _ _ _ () = str "()" in
- let printer _ _ prtac = prtac (0, E) in
- declare_extra_genarg_pprule wit_ltac printer printer pr_unit
+ let pr_unit _ _ _ _ () = str "()" in
+ let printer _ _ prtac = prtac in
+ declare_extra_genarg_pprule_with_level wit_ltac printer printer pr_unit
+ ltop (0,E)
diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli
index 5ecfaf590c..bda5774abf 100644
--- a/plugins/ltac/pptactic.mli
+++ b/plugins/ltac/pptactic.mli
@@ -40,12 +40,37 @@ type 'a extra_genarg_printer =
(tolerability -> Val.t -> Pp.t) ->
'a -> Pp.t
+type 'a raw_extra_genarg_printer_with_level =
+ (constr_expr -> Pp.t) ->
+ (constr_expr -> Pp.t) ->
+ (tolerability -> raw_tactic_expr -> Pp.t) ->
+ tolerability -> 'a -> Pp.t
+
+type 'a glob_extra_genarg_printer_with_level =
+ (glob_constr_and_expr -> Pp.t) ->
+ (glob_constr_and_expr -> Pp.t) ->
+ (tolerability -> glob_tactic_expr -> Pp.t) ->
+ tolerability -> 'a -> Pp.t
+
+type 'a extra_genarg_printer_with_level =
+ (EConstr.constr -> Pp.t) ->
+ (EConstr.constr -> Pp.t) ->
+ (tolerability -> Val.t -> Pp.t) ->
+ tolerability -> 'a -> Pp.t
+
val declare_extra_genarg_pprule :
('a, 'b, 'c) genarg_type ->
'a raw_extra_genarg_printer ->
'b glob_extra_genarg_printer ->
'c extra_genarg_printer -> unit
+val declare_extra_genarg_pprule_with_level :
+ ('a, 'b, 'c) genarg_type ->
+ 'a raw_extra_genarg_printer_with_level ->
+ 'b glob_extra_genarg_printer_with_level ->
+ 'c extra_genarg_printer_with_level ->
+ (* surroounded *) tolerability -> (* non-surroounded *) tolerability -> unit
+
val declare_extra_vernac_genarg_pprule :
('a, 'b, 'c) genarg_type ->
'a raw_extra_genarg_printer -> unit
diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml
index 9ae8bfe65b..1615465281 100644
--- a/plugins/ltac/profile_ltac.ml
+++ b/plugins/ltac/profile_ltac.ml
@@ -289,7 +289,7 @@ let rec find_in_stack what acc = function
| { name } as x :: rest when String.equal name what -> Some(acc, x, rest)
| { name } as x :: rest -> find_in_stack what (x :: acc) rest
-let exit_tactic start_time c =
+let exit_tactic ~count_call start_time c =
let diff = time () -. start_time in
match Local.(!stack) with
| [] | [_] ->
@@ -304,7 +304,7 @@ let exit_tactic start_time c =
let node = { node with
total = node.total +. diff;
local = node.local +. diff;
- ncalls = node.ncalls + 1;
+ ncalls = node.ncalls + (if count_call then 1 else 0);
max_total = max node.max_total diff;
} in
(* updating the stack *)
@@ -341,7 +341,7 @@ let tclFINALLY tac (finally : unit Proofview.tactic) =
(fun v -> finally <*> Proofview.tclUNIT v)
(fun (exn, info) -> finally <*> Proofview.tclZERO ~info exn)
-let do_profile s call_trace tac =
+let do_profile s call_trace ?(count_call=true) tac =
let open Proofview.Notations in
Proofview.tclLIFT (Proofview.NonLogical.make (fun () ->
if !is_profiling then
@@ -359,7 +359,7 @@ let do_profile s call_trace tac =
tac
(Proofview.tclLIFT (Proofview.NonLogical.make (fun () ->
(match call_trace with
- | (_, c) :: _ -> exit_tactic start_time c
+ | (_, c) :: _ -> exit_tactic ~count_call start_time c
| [] -> ()))))
| None -> tac
@@ -397,6 +397,27 @@ let reset_profile () =
reset_profile_tmp ();
data := SM.empty
+(* ****************************** Named timers ****************************** *)
+
+let timer_data = ref M.empty
+
+let timer_name = function
+ | Some v -> v
+ | None -> ""
+
+let restart_timer name =
+ timer_data := M.add (timer_name name) (System.get_time ()) !timer_data
+
+let get_timer name =
+ try M.find (timer_name name) !timer_data
+ with Not_found -> System.get_time ()
+
+let finish_timing ~prefix name =
+ let tend = System.get_time () in
+ let tstart = get_timer name in
+ Feedback.msg_info(str prefix ++ pr_opt str name ++ str " ran for " ++
+ System.fmt_time_difference tstart tend)
+
(* ******************** *)
let print_results_filter ~cutoff ~filter =
@@ -408,7 +429,7 @@ let print_results_filter ~cutoff ~filter =
let results =
SM.fold (fun _ -> merge_roots ~disjoint:true) !data (empty_treenode root) in
let results = merge_roots results Local.(CList.last !stack) in
- Feedback.msg_notice (to_string ~cutoff ~filter results)
+ Feedback.msg_info (to_string ~cutoff ~filter results)
;;
let print_results ~cutoff =
diff --git a/plugins/ltac/profile_ltac.mli b/plugins/ltac/profile_ltac.mli
index 52827cb36b..adedf7ee91 100644
--- a/plugins/ltac/profile_ltac.mli
+++ b/plugins/ltac/profile_ltac.mli
@@ -9,9 +9,39 @@
(** Ltac profiling primitives *)
+(* Note(JasonGross): Ltac semantics are a bit insane. There isn't
+ really a good notion of how many times a tactic has been "called",
+ because tactics can be partially evaluated, and it's unclear
+ whether the number of "calls" should be the number of times the
+ body is fetched and unfolded, or the number of times the code is
+ executed to a value, etc. The logic in [Tacinterp.eval_tactic]
+ gives a decent approximation, which I believe roughly corresponds
+ to the number of times that the engine runs the tactic value which
+ results from evaluating the tactic expression bound to the name
+ we're considering. However, this is a poor approximation of the
+ time spent in the tactic; we want to consider time spent evaluating
+ a tactic expression to a tactic value to be time spent in the
+ expression, not just time spent in the caller of the expression.
+ So we need to wrap some nodes in additional profiling calls which
+ don't count towards to total call count. Whether or not a call
+ "counts" is indicated by the [count_call] boolean argument.
+
+ Unfortunately, at present, we can get very strange call graphs when
+ a named tactic expression never runs as a tactic value: if we have
+ [Ltac t0 := t.] and [Ltac t1 := t0.], then [t1] is considered to
+ run 0(!) times. It evaluates to [t] during tactic expression
+ evaluation, and although the call trace records the fact that it
+ was called by [t0] which was called by [t1], the tactic running
+ phase never sees this. Thus we get one call tree (from expression
+ evaluation) that has [t1] calls [t0] calls [t], and another call
+ tree which says that the caller of [t1] calls [t] directly; the
+ expression evaluation time goes in the first tree, and the call
+ count and tactic running time goes in the second tree. Alas, I
+ suspect that fixing this requires a redesign of how the profiler
+ hooks into the tactic engine. *)
val do_profile :
string -> ('a * Tacexpr.ltac_call_kind) list ->
- 'b Proofview.tactic -> 'b Proofview.tactic
+ ?count_call:bool -> 'b Proofview.tactic -> 'b Proofview.tactic
val set_profiling : bool -> unit
@@ -22,6 +52,10 @@ val print_results_tactic : string -> unit
val reset_profile : unit -> unit
+val restart_timer : string option -> unit
+
+val finish_timing : prefix:string -> string option -> unit
+
val do_print_results_at_close : unit -> unit
(* The collected statistics for a tactic. The timing data is collected over all
@@ -46,4 +80,3 @@ type treenode = {
(* Returns the profiling results known by the current process *)
val get_local_profiling_results : unit -> treenode
val feedback_results : treenode -> unit
-
diff --git a/plugins/ltac/profile_ltac_tactics.ml4 b/plugins/ltac/profile_ltac_tactics.ml4
index 2b1106ee21..7a75662be0 100644
--- a/plugins/ltac/profile_ltac_tactics.ml4
+++ b/plugins/ltac/profile_ltac_tactics.ml4
@@ -6,28 +6,60 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
(** Ltac profiling entrypoints *)
open Profile_ltac
open Stdarg
-DECLARE PLUGIN "profile_ltac_plugin"
+DECLARE PLUGIN "ltac_plugin"
let tclSET_PROFILING b =
Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> set_profiling b))
+let tclRESET_PROFILE =
+ Proofview.tclLIFT (Proofview.NonLogical.make reset_profile)
+
+let tclSHOW_PROFILE ~cutoff =
+ Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> print_results ~cutoff))
+
+let tclSHOW_PROFILE_TACTIC s =
+ Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> print_results_tactic s))
+
+let tclRESTART_TIMER s =
+ Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> restart_timer s))
+
+let tclFINISH_TIMING ?(prefix="Timer") (s : string option) =
+ Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> finish_timing ~prefix s))
+
TACTIC EXTEND start_ltac_profiling
| [ "start" "ltac" "profiling" ] -> [ tclSET_PROFILING true ]
END
-TACTIC EXTEND stop_profiling
+TACTIC EXTEND stop_ltac_profiling
| [ "stop" "ltac" "profiling" ] -> [ tclSET_PROFILING false ]
END
+TACTIC EXTEND reset_ltac_profile
+| [ "reset" "ltac" "profile" ] -> [ tclRESET_PROFILE ]
+END
+
+TACTIC EXTEND show_ltac_profile
+| [ "show" "ltac" "profile" ] -> [ tclSHOW_PROFILE ~cutoff:!Flags.profile_ltac_cutoff ]
+| [ "show" "ltac" "profile" "cutoff" int(n) ] -> [ tclSHOW_PROFILE ~cutoff:(float_of_int n) ]
+| [ "show" "ltac" "profile" string(s) ] -> [ tclSHOW_PROFILE_TACTIC s ]
+END
+
+TACTIC EXTEND restart_timer
+| [ "restart_timer" string_opt(s) ] -> [ tclRESTART_TIMER s ]
+END
+
+TACTIC EXTEND finish_timing
+| [ "finish_timing" string_opt(s) ] -> [ tclFINISH_TIMING ~prefix:"Timer" s ]
+| [ "finish_timing" "(" string(prefix) ")" string_opt(s) ] -> [ tclFINISH_TIMING ~prefix s ]
+END
+
VERNAC COMMAND EXTEND ResetLtacProfiling CLASSIFIED AS SIDEFF
- [ "Reset" "Ltac" "Profile" ] -> [ reset_profile() ]
+ [ "Reset" "Ltac" "Profile" ] -> [ reset_profile () ]
END
VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY
diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml
index c0060c5a7c..acd7a30c43 100644
--- a/plugins/ltac/rewrite.ml
+++ b/plugins/ltac/rewrite.ml
@@ -210,9 +210,9 @@ end) = struct
let t = Reductionops.whd_all env (goalevars evars) ty in
match EConstr.kind (goalevars evars) t, l with
| Prod (na, ty, b), obj :: cstrs ->
- let b = Reductionops.nf_betaiota (goalevars evars) b in
+ let b = Reductionops.nf_betaiota env (goalevars evars) b in
if noccurn (goalevars evars) 1 b (* non-dependent product *) then
- let ty = Reductionops.nf_betaiota (goalevars evars) ty in
+ let ty = Reductionops.nf_betaiota env (goalevars evars) ty in
let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in
let evars, relty = mk_relty evars env ty obj in
let evars, newarg = app_poly env evars respectful [| ty ; b' ; relty ; arg |] in
@@ -221,7 +221,7 @@ end) = struct
let (evars, b, arg, cstrs) =
aux (push_rel (LocalAssum (na, ty)) env) evars b cstrs
in
- let ty = Reductionops.nf_betaiota (goalevars evars) ty in
+ let ty = Reductionops.nf_betaiota env (goalevars evars) ty in
let pred = mkLambda (na, ty, b) in
let liftarg = mkLambda (na, ty, arg) in
let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in
@@ -231,7 +231,7 @@ end) = struct
| _, [] ->
(match finalcstr with
| None | Some (_, None) ->
- let t = Reductionops.nf_betaiota (fst evars) ty in
+ let t = Reductionops.nf_betaiota env (fst evars) ty in
let evars, rel = mk_relty evars env t None in
evars, t, rel, [t, Some rel]
| Some (t, Some rel) -> evars, t, rel, [t, Some rel])
@@ -361,8 +361,8 @@ end) = struct
end
(* let my_type_of env evars c = Typing.e_type_of env evars c *)
-(* let mytypeofkey = Profile.declare_profile "my_type_of";; *)
-(* let my_type_of = Profile.profile3 mytypeofkey my_type_of *)
+(* let mytypeofkey = CProfile.declare_profile "my_type_of";; *)
+(* let my_type_of = CProfile.profile3 mytypeofkey my_type_of *)
let type_app_poly env env evd f args =
@@ -1557,9 +1557,8 @@ let newfail n s =
let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause =
let open Proofview.Notations in
(** For compatibility *)
- let beta_red _ sigma c = Reductionops.nf_betaiota sigma c in
- let beta = Tactics.reduct_in_concl (beta_red, DEFAULTcast) in
- let beta_hyp id = Tactics.reduct_in_hyp beta_red (id, InHyp) in
+ let beta = Tactics.reduct_in_concl (Reductionops.nf_betaiota, DEFAULTcast) in
+ let beta_hyp id = Tactics.reduct_in_hyp Reductionops.nf_betaiota (id, InHyp) in
let treat sigma res =
match res with
| None -> newfail 0 (str "Nothing to rewrite")
@@ -1781,7 +1780,9 @@ let declare_an_instance n s args =
let declare_instance a aeq n s = declare_an_instance n s [a;aeq]
let anew_instance global binders instance fields =
- new_instance (Flags.is_universe_polymorphism ())
+ let program_mode = Flags.is_program_mode () in
+ let poly = Flags.is_universe_polymorphism () in
+ new_instance ~program_mode poly
binders instance (Some (true, CAst.make @@ CRecord (fields)))
~global ~generalize:false ~refine:false Hints.empty_hint_info
@@ -1979,8 +1980,7 @@ let add_morphism_infer glob m n =
Decl_kinds.IsAssumption Decl_kinds.Logical)
in
add_instance (Typeclasses.new_instance
- (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info glob
- poly (ConstRef cst));
+ (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info glob (ConstRef cst));
declare_projection n instance_id (ConstRef cst)
else
let kind = Decl_kinds.Global, poly,
@@ -1991,7 +1991,7 @@ let add_morphism_infer glob m n =
| Globnames.ConstRef cst ->
add_instance (Typeclasses.new_instance
(Lazy.force PropGlobal.proper_class) Hints.empty_hint_info
- glob poly (ConstRef cst));
+ glob (ConstRef cst));
declare_projection n instance_id (ConstRef cst)
| _ -> assert false
in
@@ -2012,23 +2012,26 @@ let add_morphism glob binders m s n =
[cHole; s; m]))
in
let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in
- ignore(new_instance ~global:glob poly binders instance
- (Some (true, CAst.make @@ CRecord []))
- ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info)
+ let program_mode = Flags.is_program_mode () in
+ ignore(new_instance ~program_mode ~global:glob poly binders instance
+ (Some (true, CAst.make @@ CRecord []))
+ ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info)
(** Bind to "rewrite" too *)
(** Taken from original setoid_replace, to emulate the old rewrite semantics where
lemmas are first instantiated and then rewrite proceeds. *)
-let check_evar_map_of_evars_defs evd =
+let check_evar_map_of_evars_defs env evd =
let metas = Evd.meta_list evd in
let check_freemetas_is_empty rebus =
Evd.Metaset.iter
(fun m ->
- if Evd.meta_defined evd m then () else
- raise
- (Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m])))
+ if Evd.meta_defined evd m then ()
+ else begin
+ raise
+ (Logic.RefinerError (env, evd, Logic.UnresolvedBindings [Evd.meta_name evd m]))
+ end)
in
List.iter
(fun (_,binding) ->
@@ -2063,7 +2066,7 @@ let unification_rewrite l2r c1 c2 sigma prf car rel but env =
let c1 = if l2r then nf c' else nf c1
and c2 = if l2r then nf c2 else nf c'
and car = nf car and rel = nf rel in
- check_evar_map_of_evars_defs sigma;
+ check_evar_map_of_evars_defs env sigma;
let prf = nf prf in
let prfty = nf (Retyping.get_type_of env sigma prf) in
let sort = sort_of_rel env sigma but in
@@ -2084,8 +2087,8 @@ let get_hyp gl (c,l) clause l2r =
let general_rewrite_flags = { under_lambdas = false; on_morphisms = true }
-(* let rewriteclaustac_key = Profile.declare_profile "cl_rewrite_clause_tac";; *)
-(* let cl_rewrite_clause_tac = Profile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *)
+(* let rewriteclaustac_key = CProfile.declare_profile "cl_rewrite_clause_tac";; *)
+(* let cl_rewrite_clause_tac = CProfile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *)
(** Setoid rewriting when called with "rewrite" *)
let general_s_rewrite cl l2r occs (c,l) ~new_goals =
diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml
index c03a867326..e5933de2a6 100644
--- a/plugins/ltac/taccoerce.ml
+++ b/plugins/ltac/taccoerce.ml
@@ -33,7 +33,7 @@ let (wit_constr_under_binders : (Empty.t, Empty.t, Ltac_pretype.constr_under_bin
let () = register_val0 wit None in
let () = Genprint.register_val_print0 (base_val_typ wit)
(fun c ->
- Genprint.PrinterNeedsContext (fun env sigma -> Printer.pr_constr_under_binders_env env sigma c)) in
+ Genprint.TopPrinterNeedsContext (fun env sigma -> Printer.pr_constr_under_binders_env env sigma c)) in
wit
(** All the types considered here are base types *)
@@ -61,12 +61,9 @@ struct
type t = Val.t
-let normalize v = v
-
let of_constr c = in_gen (topwit wit_constr) c
let to_constr v =
- let v = normalize v in
if has_type v (topwit wit_constr) then
let c = out_gen (topwit wit_constr) v in
Some c
@@ -78,7 +75,6 @@ let to_constr v =
let of_uconstr c = in_gen (topwit wit_uconstr) c
let to_uconstr v =
- let v = normalize v in
if has_type v (topwit wit_uconstr) then
Some (out_gen (topwit wit_uconstr) v)
else None
@@ -86,7 +82,6 @@ let to_uconstr v =
let of_int i = in_gen (topwit wit_int) i
let to_int v =
- let v = normalize v in
if has_type v (topwit wit_int) then
Some (out_gen (topwit wit_int) v)
else None
@@ -108,14 +103,12 @@ let constr_of_id env id =
(* Gives the constr corresponding to a Constr_context tactic_arg *)
let coerce_to_constr_context v =
- let v = Value.normalize v in
if has_type v (topwit wit_constr_context) then
out_gen (topwit wit_constr_context) v
else raise (CannotCoerceTo "a term context")
(* Interprets an identifier which must be fresh *)
let coerce_var_to_ident fresh env sigma v =
- let v = Value.normalize v in
let fail () = raise (CannotCoerceTo "a fresh identifier") in
if has_type v (topwit wit_intro_pattern) then
match out_gen (topwit wit_intro_pattern) v with
@@ -140,7 +133,6 @@ let g = sigma in
let id_of_name = function
| Name.Anonymous -> Id.of_string "x"
| Name.Name x -> x in
- let v = Value.normalize v in
let fail () = raise (CannotCoerceTo "an identifier") in
if has_type v (topwit wit_intro_pattern) then
match out_gen (topwit wit_intro_pattern) v with
@@ -179,7 +171,6 @@ let id_of_name = function
let coerce_to_intro_pattern env sigma v =
- let v = Value.normalize v in
if has_type v (topwit wit_intro_pattern) then
snd (out_gen (topwit wit_intro_pattern) v)
else if has_type v (topwit wit_var) then
@@ -198,7 +189,6 @@ let coerce_to_intro_pattern_naming env sigma v =
| _ -> raise (CannotCoerceTo "a naming introduction pattern")
let coerce_to_hint_base v =
- let v = Value.normalize v in
if has_type v (topwit wit_intro_pattern) then
match out_gen (topwit wit_intro_pattern) v with
| _, IntroNaming (IntroIdentifier id) -> Id.to_string id
@@ -206,13 +196,11 @@ let coerce_to_hint_base v =
else raise (CannotCoerceTo "a hint base name")
let coerce_to_int v =
- let v = Value.normalize v in
if has_type v (topwit wit_int) then
out_gen (topwit wit_int) v
else raise (CannotCoerceTo "an integer")
let coerce_to_constr env v =
- let v = Value.normalize v in
let fail () = raise (CannotCoerceTo "a term") in
if has_type v (topwit wit_intro_pattern) then
match out_gen (topwit wit_intro_pattern) v with
@@ -230,7 +218,6 @@ let coerce_to_constr env v =
else fail ()
let coerce_to_uconstr env v =
- let v = Value.normalize v in
if has_type v (topwit wit_uconstr) then
out_gen (topwit wit_uconstr) v
else
@@ -243,7 +230,6 @@ let coerce_to_closed_constr env v =
let coerce_to_evaluable_ref env sigma v =
let fail () = raise (CannotCoerceTo "an evaluable reference") in
- let v = Value.normalize v in
let ev =
if has_type v (topwit wit_intro_pattern) then
match out_gen (topwit wit_intro_pattern) v with
@@ -284,7 +270,6 @@ let coerce_to_intro_pattern_list ?loc env sigma v =
let coerce_to_hyp env sigma v =
let fail () = raise (CannotCoerceTo "a variable") in
- let v = Value.normalize v in
if has_type v (topwit wit_intro_pattern) then
match out_gen (topwit wit_intro_pattern) v with
| _, IntroNaming (IntroIdentifier id) when is_variable env id -> id
@@ -306,7 +291,6 @@ let coerce_to_hyp_list env sigma v =
(* Interprets a qualified name *)
let coerce_to_reference env sigma v =
- let v = Value.normalize v in
match Value.to_constr v with
| Some c ->
begin
@@ -318,7 +302,6 @@ let coerce_to_reference env sigma v =
(* Quantified named or numbered hypothesis or hypothesis in context *)
(* (as in Inversion) *)
let coerce_to_quantified_hypothesis sigma v =
- let v = Value.normalize v in
if has_type v (topwit wit_intro_pattern) then
let v = out_gen (topwit wit_intro_pattern) v in
match v with
@@ -336,7 +319,6 @@ let coerce_to_quantified_hypothesis sigma v =
(* Quantified named or numbered hypothesis or hypothesis in context *)
(* (as in Inversion) *)
let coerce_to_decl_or_quant_hyp env sigma v =
- let v = Value.normalize v in
if has_type v (topwit wit_int) then
AnonHyp (out_gen (topwit wit_int) v)
else
diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli
index d7b253a687..dce16b7333 100644
--- a/plugins/ltac/taccoerce.mli
+++ b/plugins/ltac/taccoerce.mli
@@ -31,9 +31,6 @@ module Value :
sig
type t = Val.t
- val normalize : t -> t
- (** Eliminated the leading dynamic type casts. *)
-
val of_constr : constr -> t
val to_constr : t -> constr option
val of_uconstr : Ltac_pretype.closed_glob_constr -> t
diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml
index ee84be5414..8112cc4008 100644
--- a/plugins/ltac/tacentries.ml
+++ b/plugins/ltac/tacentries.ml
@@ -545,11 +545,10 @@ let print_located_tactic qid =
(** Grammar *)
let () =
- let open Metasyntax in
let entries = [
AnyEntry Pltac.tactic_expr;
AnyEntry Pltac.binder_tactic;
AnyEntry Pltac.simple_tactic;
AnyEntry Pltac.tactic_arg;
] in
- register_grammar "tactic" entries
+ register_grammars_by_name "tactic" entries
diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli
index 9bd3efc6b7..ccd555b615 100644
--- a/plugins/ltac/tacexpr.mli
+++ b/plugins/ltac/tacexpr.mli
@@ -81,7 +81,7 @@ type 'a with_bindings_arg = clear_flag * 'a with_bindings
(* Type of patterns *)
type 'a match_pattern =
| Term of 'a
- | Subterm of bool * Id.t option * 'a
+ | Subterm of Id.t option * 'a
(* Type of hypotheses for a Match Context rule *)
type 'a match_context_hyps =
diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml
index b16b0a7bae..ebffde441d 100644
--- a/plugins/ltac/tacintern.ml
+++ b/plugins/ltac/tacintern.ml
@@ -428,9 +428,9 @@ let intern_hyp_location ist ((occs,id),hl) =
(* Reads a pattern *)
let intern_pattern ist ?(as_type=false) ltacvars = function
- | Subterm (b,ido,pc) ->
+ | Subterm (ido,pc) ->
let (metas,pc) = intern_constr_pattern ist ~as_type:false ~ltacvars pc in
- ido, metas, Subterm (b,ido,pc)
+ ido, metas, Subterm (ido,pc)
| Term pc ->
let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in
None, metas, Term pc
diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml
index 1a8ec6d6f6..f2720954d0 100644
--- a/plugins/ltac/tacinterp.ml
+++ b/plugins/ltac/tacinterp.ml
@@ -128,7 +128,7 @@ let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) =
let wit = Genarg.create_arg "tacvalue" in
let () = register_val0 wit None in
let () = Genprint.register_val_print0 (base_val_typ wit)
- (fun _ -> Genprint.PrinterBasic (fun () -> str "<tactic closure>")) in
+ (fun _ -> Genprint.TopPrinterBasic (fun () -> str "<tactic closure>")) in
wit
let of_tacvalue v = in_gen (topwit wit_tacvalue) v
@@ -136,7 +136,6 @@ let to_tacvalue v = out_gen (topwit wit_tacvalue) v
(** More naming applications *)
let name_vfun appl vle =
- let vle = Value.normalize vle in
if has_type vle (topwit wit_tacvalue) then
match to_tacvalue vle with
| VFun (appl0,trace,lfun,vars,t) -> of_tacvalue (VFun (combine_appl appl0 appl,trace,lfun,vars,t))
@@ -235,16 +234,15 @@ let curr_debug ist = match TacStore.get ist.extra f_debug with
(* Displays a value *)
let pr_value env v =
- let v = Value.normalize v in
let pr_with_env pr =
match env with
| Some (env,sigma) -> pr env sigma
| None -> str "a value of type" ++ spc () ++ pr_argument_type v in
let open Genprint in
match generic_val_print v with
- | PrinterBasic pr -> pr ()
- | PrinterNeedsContext pr -> pr_with_env pr
- | PrinterNeedsContextAndLevel { default_already_surrounded; printer } ->
+ | TopPrinterBasic pr -> pr ()
+ | TopPrinterNeedsContext pr -> pr_with_env pr
+ | TopPrinterNeedsContextAndLevel { default_already_surrounded; printer } ->
pr_with_env (fun env sigma -> printer env sigma default_already_surrounded)
let pr_closure env ist body =
@@ -285,7 +283,6 @@ let push_trace call ist = match TacStore.get ist.extra f_trace with
| Some trace -> Proofview.tclUNIT (call :: trace)
let propagate_trace ist loc id v =
- let v = Value.normalize v in
if has_type v (topwit wit_tacvalue) then
let tacv = to_tacvalue v in
match tacv with
@@ -298,7 +295,6 @@ let propagate_trace ist loc id v =
else Proofview.tclUNIT v
let append_trace trace v =
- let v = Value.normalize v in
if has_type v (topwit wit_tacvalue) then
match to_tacvalue v with
| VFun (appl,trace',lfun,it,b) -> of_tacvalue (VFun (appl,trace'@trace,lfun,it,b))
@@ -307,11 +303,9 @@ let append_trace trace v =
(* Dynamically check that an argument is a tactic *)
let coerce_to_tactic loc id v =
- let v = Value.normalize v in
let fail () = user_err ?loc
(str "Variable " ++ Id.print id ++ str " should be bound to a tactic.")
in
- let v = Value.normalize v in
if has_type v (topwit wit_tacvalue) then
let tacv = to_tacvalue v in
match tacv with
@@ -420,7 +414,7 @@ let interp_hyp ist env sigma (loc,id as locid) =
with Not_found ->
(* Then look if bound in the proof context at calling time *)
if is_variable env id then id
- else Loc.raise ?loc (Logic.RefinerError (Logic.NoSuchHyp id))
+ else Loc.raise ?loc (Logic.RefinerError (env, sigma, Logic.NoSuchHyp id))
let interp_hyp_list_as_list ist env sigma (loc,id as x) =
try coerce_to_hyp_list env sigma (Id.Map.find id ist.lfun)
@@ -514,7 +508,6 @@ let rec intropattern_ids accu (loc,pat) = match pat with
let extract_ids ids lfun accu =
let fold id v accu =
- let v = Value.normalize v in
if has_type v (topwit wit_intro_pattern) then
let (_, ipat) = out_gen (topwit wit_intro_pattern) v in
if Id.List.mem id ids then accu
@@ -816,14 +809,13 @@ let interp_constr_may_eval ist env sigma c =
(** TODO: should use dedicated printers *)
let message_of_value v =
- let v = Value.normalize v in
let pr_with_env pr =
Ftactic.enter begin fun gl -> Ftactic.return (pr (pf_env gl) (project gl)) end in
let open Genprint in
match generic_val_print v with
- | PrinterBasic pr -> Ftactic.return (pr ())
- | PrinterNeedsContext pr -> pr_with_env pr
- | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } ->
+ | TopPrinterBasic pr -> Ftactic.return (pr ())
+ | TopPrinterNeedsContext pr -> pr_with_env pr
+ | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } ->
pr_with_env (fun env sigma -> printer env sigma default_ensure_surrounded)
let interp_message_token ist = function
@@ -890,7 +882,7 @@ let interp_intro_pattern_naming_option ist env sigma = function
let interp_or_and_intro_pattern_option ist env sigma = function
| None -> sigma, None
| Some (ArgVar (loc,id)) ->
- (match coerce_to_intro_pattern env sigma (Id.Map.find id ist.lfun) with
+ (match interp_intro_pattern_var loc ist env sigma id with
| IntroAction (IntroOrAndPattern l) -> sigma, Some (loc,l)
| _ ->
user_err ?loc (str "Cannot coerce to a disjunctive/conjunctive pattern."))
@@ -986,7 +978,6 @@ let interp_destruction_arg ist gl arg =
try
(** FIXME: should be moved to taccoerce *)
let v = Id.Map.find id ist.lfun in
- let v = Value.normalize v in
if has_type v (topwit wit_intro_pattern) then
let v = out_gen (topwit wit_intro_pattern) v in
match v with
@@ -1040,7 +1031,7 @@ let eval_pattern lfun ist env sigma (bvars,(glob,_),pat as c) =
(bvars,instantiate_pattern env sigma lfun pat)
let read_pattern lfun ist env sigma = function
- | Subterm (b,ido,c) -> Subterm (b,ido,eval_pattern lfun ist env sigma c)
+ | Subterm (ido,c) -> Subterm (ido,eval_pattern lfun ist env sigma c)
| Term c -> Term (eval_pattern lfun ist env sigma c)
(* Reads the hypotheses of a Match Context rule *)
@@ -1158,10 +1149,14 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with
Proofview.V82.tactic begin
tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac))
end
- | TacAbstract (tac,ido) ->
+ | TacAbstract (t,ido) ->
+ let call = LtacMLCall tac in
+ push_trace(None,call) ist >>= fun trace ->
+ Profile_ltac.do_profile "eval_tactic:TacAbstract" trace
+ (catch_error_tac trace begin
Proofview.Goal.enter begin fun gl -> Tactics.tclABSTRACT
- (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist tac)
- end
+ (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist t)
+ end end)
| TacThen (t1,t) ->
Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t)
| TacDispatch tl ->
@@ -1244,7 +1239,6 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with
Ftactic.run args tac
and force_vrec ist v : Val.t Ftactic.t =
- let v = Value.normalize v in
if has_type v (topwit wit_tacvalue) then
let v = to_tacvalue v in
match v with
@@ -1272,7 +1266,8 @@ and interp_ltac_reference ?loc' mustbetac ist r : Val.t Ftactic.t =
let extra = TacStore.set extra f_trace trace in
let ist = { lfun = Id.Map.empty; extra = extra; } in
let appl = GlbAppl[r,[]] in
- val_interp ~appl ist (Tacenv.interp_ltac r)
+ Profile_ltac.do_profile "interp_ltac_reference" trace ~count_call:false
+ (val_interp ~appl ist (Tacenv.interp_ltac r))
and interp_tacarg ist arg : Val.t Ftactic.t =
match arg with
@@ -1319,7 +1314,6 @@ and interp_tacarg ist arg : Val.t Ftactic.t =
and interp_app loc ist fv largs : Val.t Ftactic.t =
let (>>=) = Ftactic.bind in
let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in
- let fv = Value.normalize fv in
if has_type fv (topwit wit_tacvalue) then
match to_tacvalue fv with
(* if var=[] and body has been delayed by val_interp, then body
@@ -1338,7 +1332,8 @@ and interp_app loc ist fv largs : Val.t Ftactic.t =
let ist = {
lfun = newlfun;
extra = TacStore.set ist.extra f_trace []; } in
- catch_error_tac trace (val_interp ist body) >>= fun v ->
+ Profile_ltac.do_profile "interp_app" trace ~count_call:false
+ (catch_error_tac trace (val_interp ist body)) >>= fun v ->
Ftactic.return (name_vfun (push_appl appl largs) v)
end
begin fun (e, info) ->
@@ -1353,8 +1348,8 @@ and interp_app loc ist fv largs : Val.t Ftactic.t =
begin
let open Genprint in
match generic_val_print v with
- | PrinterBasic _ -> call_debug None
- | PrinterNeedsContext _ | PrinterNeedsContextAndLevel _ ->
+ | TopPrinterBasic _ -> call_debug None
+ | TopPrinterNeedsContext _ | TopPrinterNeedsContextAndLevel _ ->
Proofview.Goal.enter (fun gl -> call_debug (Some (pf_env gl,project gl)))
end <*>
if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval
@@ -1371,7 +1366,6 @@ and interp_app loc ist fv largs : Val.t Ftactic.t =
(* Gives the tactic corresponding to the tactic value *)
and tactic_of_value ist vle =
- let vle = Value.normalize vle in
if has_type vle (topwit wit_tacvalue) then
match to_tacvalue vle with
| VFun (appl,trace,lfun,[],t) ->
@@ -1380,13 +1374,38 @@ and tactic_of_value ist vle =
extra = TacStore.set ist.extra f_trace []; } in
let tac = name_if_glob appl (eval_tactic ist t) in
Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac)
- | VFun (_, _, _,vars,_) ->
- let numargs = List.length vars in
- Tacticals.New.tclZEROMSG
- (str "A fully applied tactic is expected:" ++ spc() ++ Pp.str "missing " ++
- Pp.str (String.plural numargs "argument") ++ Pp.str " for " ++
- Pp.str (String.plural numargs "variable") ++ Pp.str " " ++
- pr_enum Name.print vars ++ Pp.str ".")
+ | VFun (appl,_,vmap,vars,_) ->
+ let tactic_nm =
+ match appl with
+ UnnamedAppl -> "An unnamed user-defined tactic"
+ | GlbAppl apps ->
+ let nms = List.map (fun (kn,_) -> Names.KerName.to_string kn) apps in
+ match nms with
+ [] -> assert false
+ | kn::_ -> "The user-defined tactic \"" ^ kn ^ "\"" (* TODO: when do we not have a singleton? *)
+ in
+ let numargs = List.length vars in
+ let givenargs =
+ List.map (fun (arg,_) -> Names.Id.to_string arg) (Names.Id.Map.bindings vmap) in
+ let numgiven = List.length givenargs in
+ Tacticals.New.tclZEROMSG
+ (Pp.str tactic_nm ++ Pp.str " was not fully applied:" ++ spc() ++
+ (match numargs with
+ 0 -> assert false
+ | 1 ->
+ Pp.str "There is a missing argument for variable " ++
+ (Name.print (List.hd vars))
+ | _ -> Pp.str "There are missing arguments for variables " ++
+ pr_enum Name.print vars) ++ Pp.pr_comma () ++
+ match numgiven with
+ 0 ->
+ Pp.str "no arguments at all were provided."
+ | 1 ->
+ Pp.str "an argument was provided for variable " ++
+ Pp.str (List.hd givenargs) ++ Pp.str "."
+ | _ ->
+ Pp.str "arguments were provided for variables " ++
+ pr_enum Pp.str givenargs ++ Pp.str ".")
| VRec _ -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.")
else if has_type vle (topwit wit_tactic) then
let tac = out_gen (topwit wit_tactic) vle in
@@ -1573,7 +1592,6 @@ and interp_ltac_constr ist e : EConstr.t Ftactic.t =
Ftactic.enter begin fun gl ->
let env = Proofview.Goal.env gl in
let sigma = project gl in
- let result = Value.normalize result in
try
let cresult = coerce_to_closed_constr env result in
Proofview.tclLIFT begin
diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml
index 918d1faebe..79bf3685e2 100644
--- a/plugins/ltac/tacsubst.ml
+++ b/plugins/ltac/tacsubst.ml
@@ -121,7 +121,7 @@ let subst_raw_may_eval subst = function
| ConstrTerm c -> ConstrTerm (subst_glob_constr subst c)
let subst_match_pattern subst = function
- | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_glob_constr_or_pattern subst pc))
+ | Subterm (ido,pc) -> Subterm (ido,(subst_glob_constr_or_pattern subst pc))
| Term pc -> Term (subst_glob_constr_or_pattern subst pc)
let rec subst_match_goal_hyps subst = function
diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml
index 89b78e5907..e87951dd7f 100644
--- a/plugins/ltac/tactic_matching.ml
+++ b/plugins/ltac/tactic_matching.ml
@@ -237,7 +237,7 @@ module PatternMatching (E:StaticEnvironment) = struct
return lhs
with Constr_matching.PatternMatchingFailure -> fail
end
- | Subterm (with_app_context,id_ctxt,p) ->
+ | Subterm (id_ctxt,p) ->
let rec map s (e, info) =
{ stream = fun k ctx -> match IStream.peek s with
@@ -252,7 +252,7 @@ module PatternMatching (E:StaticEnvironment) = struct
| Some nctx -> Proofview.tclOR (k lhs nctx) (fun e -> (map s e).stream k ctx)
}
in
- map (Constr_matching.match_subterm_gen E.env E.sigma with_app_context p term) imatching_error
+ map (Constr_matching.match_subterm E.env E.sigma p term) imatching_error
(** [rule_match_term term rule] matches the term [term] with the
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-04 15:47:32 +0000