From 0929a78f9a663ac2bcdf1294de93797b9fdfefad Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Sat, 4 Feb 2017 01:50:58 +0100 Subject: Extraction: fix complexity issue #5310 A double call to pp_module_type inside Ocaml.pp_specif was causing an complexity blowup when pretty-printing heavily modular extracted code. I wasn't able to figure out why this double call is there. It could be the leftover of some intermediate work in 2007 before commit 350398eae (which introduced global printing phases Pre/Impl/Intf). Anyway I'm reasonably sure that today these two pp_module_type calls produce the exact same pretty-printed signature (even if there's a large bunch of imperative states around). Moreover, this duplicated signature is actually slightly wrong: when we alias a module M with a unambiguous name like Coq__123, the type of Coq__123 should not be an exact copy of the type of M, but rather a "strengthened" version of it (with equality between inductive types). So the best solution is now to use this funny feature of OCaml introduced in 3.12 : module Coq__123 : module type of struct include M end This "module type of struct include" is slightly awkward, but short, correct, and trivial to produce :-). And I doubt anybody will object to the (rare) use of some 3.12 features in extracted code of 2017... --- plugins/extraction/ocaml.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'plugins') diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 1c29a9bc2..5d10cb939 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -618,12 +618,13 @@ let rec pp_specif = function with Not_found -> pp_spec s) | (l,Smodule mt) -> let def = pp_module_type [] mt in - let def' = pp_module_type [] mt in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 (str "module " ++ name ++ str " :" ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in - fnl () ++ hov 1 (str ("module "^ren^" :") ++ fnl () ++ def') + fnl () ++ + hov 1 (str ("module "^ren^" :") ++ spc () ++ + str "module type of struct include " ++ name ++ str " end") with Not_found -> Pp.mt ()) | (l,Smodtype mt) -> let def = pp_module_type [] mt in -- cgit v1.2.3 From e6127d1f65a761a27c80b81c0f1bc5fca2b74af8 Mon Sep 17 00:00:00 2001 From: Tej Chajed Date: Thu, 16 Feb 2017 10:24:15 -0500 Subject: [cleanup] Change Id.t option to Name.t in TacFun --- dev/doc/changes.txt | 3 +++ grammar/q_util.mli | 2 ++ grammar/q_util.mlp | 4 ++++ grammar/tacextend.mlp | 2 +- ltac/g_auto.ml4 | 1 + ltac/g_class.ml4 | 1 + ltac/g_eqdecide.ml4 | 1 + ltac/g_ltac.ml4 | 9 +++++---- ltac/pptactic.ml | 4 +--- ltac/tacentries.ml | 5 +---- ltac/tacexpr.mli | 2 +- ltac/tacintern.ml | 6 ++---- ltac/tacinterp.ml | 10 +++++----- ltac/tacinterp.mli | 2 +- ltac/tauto.ml | 2 +- plugins/nsatz/g_nsatz.ml4 | 2 ++ plugins/setoid_ring/newring.ml | 12 ++++++------ plugins/ssrmatching/ssrmatching.ml4 | 2 +- 18 files changed, 39 insertions(+), 31 deletions(-) (limited to 'plugins') diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index f54f3fcc8..2a083b360 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -40,6 +40,9 @@ important things: - Some printing functions were moved from Pptactic to Pputils - A part of Tacexpr has been moved to Tactypes +The TacFun tactic expression constructor now takes a `Name.t list` for the +variable list rather than an `Id.t option list`. + ** Error handling ** - All error functions now take an optional parameter `?loc:Loc.t`. For diff --git a/grammar/q_util.mli b/grammar/q_util.mli index a5e36e47b..37ec1d56a 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -41,6 +41,8 @@ val mlexpr_of_string : string -> MLast.expr val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr +val mlexpr_of_name : ('a -> MLast.expr) -> 'a option -> MLast.expr + val mlexpr_of_prod_entry_key : (string -> MLast.expr) -> user_symbol -> MLast.expr val type_of_user_symbol : user_symbol -> argument_type diff --git a/grammar/q_util.mlp b/grammar/q_util.mlp index 919ca3ad7..0dd096ef7 100644 --- a/grammar/q_util.mlp +++ b/grammar/q_util.mlp @@ -58,6 +58,10 @@ let mlexpr_of_option f = function | None -> <:expr< None >> | Some e -> <:expr< Some $f e$ >> +let mlexpr_of_name f = function + | None -> <:expr< Anonymous >> + | Some e -> <:expr< Name $f e$ >> + let symbol_of_string s = <:expr< Extend.Atoken (CLexer.terminal $str:s$) >> let rec mlexpr_of_prod_entry_key f = function diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp index fe864ed40..8605dda3a 100644 --- a/grammar/tacextend.mlp +++ b/grammar/tacextend.mlp @@ -88,7 +88,7 @@ let declare_tactic loc s c cl = match cl with add any grammar nor printing rule and add it as a true Ltac definition. *) let patt = make_patt rem in let vars = List.map make_var rem in - let vars = mlexpr_of_list (mlexpr_of_option mlexpr_of_ident) vars in + let vars = mlexpr_of_list (mlexpr_of_name mlexpr_of_ident) vars in let entry = mlexpr_of_string s in let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in let ml = <:expr< { Tacexpr.mltac_name = $se$; Tacexpr.mltac_index = 0 } >> in diff --git a/ltac/g_auto.ml4 b/ltac/g_auto.ml4 index a37cf306e..f32548cd3 100644 --- a/ltac/g_auto.ml4 +++ b/ltac/g_auto.ml4 @@ -16,6 +16,7 @@ open Pcoq.Constr open Pltac open Hints open Tacexpr +open Names DECLARE PLUGIN "g_auto" diff --git a/ltac/g_class.ml4 b/ltac/g_class.ml4 index a28132a4b..ca9537c82 100644 --- a/ltac/g_class.ml4 +++ b/ltac/g_class.ml4 @@ -13,6 +13,7 @@ open Class_tactics open Pltac open Stdarg open Tacarg +open Names DECLARE PLUGIN "g_class" diff --git a/ltac/g_eqdecide.ml4 b/ltac/g_eqdecide.ml4 index 905653281..679aa1127 100644 --- a/ltac/g_eqdecide.ml4 +++ b/ltac/g_eqdecide.ml4 @@ -15,6 +15,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) open Eqdecide +open Names DECLARE PLUGIN "g_eqdecide" diff --git a/ltac/g_ltac.ml4 b/ltac/g_ltac.ml4 index 54229bb2a..aab568746 100644 --- a/ltac/g_ltac.ml4 +++ b/ltac/g_ltac.ml4 @@ -17,6 +17,7 @@ open Misctypes open Genarg open Genredexpr open Tok (* necessary for camlp4 *) +open Names open Pcoq open Pcoq.Constr @@ -226,8 +227,8 @@ GEXTEND Gram | "multimatch" -> General ] ] ; input_fun: - [ [ "_" -> None - | l = ident -> Some l ] ] + [ [ "_" -> Anonymous + | l = ident -> Name l ] ] ; let_clause: [ [ id = identref; ":="; te = tactic_expr -> @@ -499,8 +500,8 @@ let pr_tacdef_body tacdef_body = | Tacexpr.TacFun (idl,b) -> idl,b | _ -> [], body in id ++ - prlist (function None -> str " _" - | Some id -> spc () ++ Nameops.pr_id id) idl + prlist (function Anonymous -> str " _" + | Name id -> spc () ++ Nameops.pr_id id) idl ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) ++ Pptactic.pr_raw_tactic body diff --git a/ltac/pptactic.ml b/ltac/pptactic.ml index fccee6e40..6f4ef37b4 100644 --- a/ltac/pptactic.ml +++ b/ltac/pptactic.ml @@ -574,9 +574,7 @@ module Make str "=>" ++ brk (1,4) ++ pr t)) | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t - let pr_funvar = function - | None -> spc () ++ str "_" - | Some id -> spc () ++ pr_id id + let pr_funvar n = spc () ++ pr_name n let pr_let_clause k pr (id,(bl,t)) = hov 0 (keyword k ++ spc () ++ pr_lident id ++ prlist pr_funvar bl ++ diff --git a/ltac/tacentries.ml b/ltac/tacentries.ml index 2e2b55be7..75edf150e 100644 --- a/ltac/tacentries.ml +++ b/ltac/tacentries.ml @@ -504,10 +504,7 @@ let print_ltacs () = | Tacexpr.TacFun (l, t) -> (l, t) | _ -> ([], body) in - let pr_ltac_fun_arg = function - | None -> spc () ++ str "_" - | Some id -> spc () ++ pr_id id - in + let pr_ltac_fun_arg n = spc () ++ pr_name n in hov 2 (pr_qualid qid ++ prlist pr_ltac_fun_arg l) in Feedback.msg_notice (prlist_with_sep fnl pr_entry entries) diff --git a/ltac/tacexpr.mli b/ltac/tacexpr.mli index 9c25a1645..e23992a80 100644 --- a/ltac/tacexpr.mli +++ b/ltac/tacexpr.mli @@ -282,7 +282,7 @@ constraint 'a = < > and 'a gen_tactic_fun_ast = - Id.t option list * 'a gen_tactic_expr + Name.t list * 'a gen_tactic_expr constraint 'a = < term:'t; diff --git a/ltac/tacintern.ml b/ltac/tacintern.ml index 763e0dc22..3292c8353 100644 --- a/ltac/tacintern.ml +++ b/ltac/tacintern.ml @@ -646,7 +646,7 @@ and intern_tactic_or_tacarg ist = intern_tactic false ist and intern_pure_tactic ist = intern_tactic true ist and intern_tactic_fun ist (var,body) = - let lfun = List.fold_left opt_cons ist.ltacvars var in + let lfun = List.fold_left name_cons ist.ltacvars var in (var,intern_tactic_or_tacarg { ist with ltacvars = lfun } body) and intern_tacarg strict onlytac ist = function @@ -722,9 +722,7 @@ let split_ltac_fun = function | TacFun (l,t) -> (l,t) | t -> ([],t) -let pr_ltac_fun_arg = function - | None -> spc () ++ str "_" - | Some id -> spc () ++ pr_id id +let pr_ltac_fun_arg n = spc () ++ pr_name n let print_ltac id = try diff --git a/ltac/tacinterp.ml b/ltac/tacinterp.ml index 32bcdfb6a..adc393d2c 100644 --- a/ltac/tacinterp.ml +++ b/ltac/tacinterp.ml @@ -120,7 +120,7 @@ let combine_appl appl1 appl2 = (* Values for interpretation *) type tacvalue = | VFun of appl*ltac_trace * value Id.Map.t * - Id.t option list * glob_tactic_expr + Name.t list * glob_tactic_expr | VRec of value Id.Map.t ref * glob_tactic_expr let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = @@ -1087,8 +1087,8 @@ let head_with_value (lvar,lval) = | ([],[]) -> (lacc,[],[]) | (vr::tvr,ve::tve) -> (match vr with - | None -> head_with_value_rec lacc (tvr,tve) - | Some v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve)) + | Anonymous -> head_with_value_rec lacc (tvr,tve) + | Name v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve)) | (vr,[]) -> (lacc,vr,[]) | ([],ve) -> (lacc,[],ve) in @@ -2119,8 +2119,8 @@ let lift_constr_tac_to_ml_tac vars tac = let env = Proofview.Goal.env gl in let sigma = project gl in let map = function - | None -> None - | Some id -> + | Anonymous -> None + | Name id -> let c = Id.Map.find id ist.lfun in try Some (coerce_to_closed_constr env c) with CannotCoerceTo ty -> diff --git a/ltac/tacinterp.mli b/ltac/tacinterp.mli index 6f64981ef..adbd1d32b 100644 --- a/ltac/tacinterp.mli +++ b/ltac/tacinterp.mli @@ -115,7 +115,7 @@ val error_ltac_variable : Loc.t -> Id.t -> (** Transforms a constr-expecting tactic into a tactic finding its arguments in the Ltac environment according to the given names. *) -val lift_constr_tac_to_ml_tac : Id.t option list -> +val lift_constr_tac_to_ml_tac : Name.t list -> (constr list -> Geninterp.interp_sign -> unit Proofview.tactic) -> Tacenv.ml_tactic val default_ist : unit -> Geninterp.interp_sign diff --git a/ltac/tauto.ml b/ltac/tauto.ml index 756958c2f..fb05fd7d0 100644 --- a/ltac/tauto.ml +++ b/ltac/tauto.ml @@ -259,7 +259,7 @@ let with_flags flags _ ist = let register_tauto_tactic tac name0 args = let ids = List.map (fun id -> Id.of_string id) args in - let ids = List.map (fun id -> Some id) ids in + let ids = List.map (fun id -> Name id) ids in let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in let entry = { mltac_name = name; mltac_index = 0 } in let () = Tacenv.register_ml_tactic name [| tac |] in diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.ml4 index 5f906a8da..fda7c0fa8 100644 --- a/plugins/nsatz/g_nsatz.ml4 +++ b/plugins/nsatz/g_nsatz.ml4 @@ -10,6 +10,8 @@ DECLARE PLUGIN "nsatz_plugin" (*i camlp4deps: "grammar/grammar.cma" i*) +open Names + DECLARE PLUGIN "nsatz_plugin" TACTIC EXTEND nsatz_compute diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 657efe175..d1f3bd6d3 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -122,7 +122,7 @@ let closed_term_ast l = mltac_index = 0; } in let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in - TacFun([Some(Id.of_string"t")], + TacFun([Name(Id.of_string"t")], TacML(Loc.ghost,tacname, [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None)); TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Stdarg.wit_ref)) l)])) @@ -205,7 +205,7 @@ let exec_tactic env evd n f args = let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in let get_res = TacML (Loc.ghost, get_res, [TacGeneric n]) in - let getter = Tacexp (TacFun (List.map (fun id -> Some id) lid, get_res)) in + let getter = Tacexp (TacFun (List.map (fun n -> Name n) lid, get_res)) in (** Evaluate the whole result *) let gl = dummy_goal env evd in let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in @@ -722,8 +722,8 @@ let ltac_ring_structure e = let pow_tac = tacarg e.ring_pow_tac in let lemma1 = carg e.ring_lemma1 in let lemma2 = carg e.ring_lemma2 in - let pretac = tacarg (TacFun([None],e.ring_pre_tac)) in - let posttac = tacarg (TacFun([None],e.ring_post_tac)) in + let pretac = tacarg (TacFun([Anonymous],e.ring_pre_tac)) in + let posttac = tacarg (TacFun([Anonymous],e.ring_post_tac)) in [req;sth;ext;morph;th;cst_tac;pow_tac; lemma1;lemma2;pretac;posttac] @@ -994,8 +994,8 @@ let ltac_field_structure e = let field_simpl_eq_ok = carg e.field_simpl_eq_ok in let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in let cond_ok = carg e.field_cond in - let pretac = tacarg (TacFun([None],e.field_pre_tac)) in - let posttac = tacarg (TacFun([None],e.field_post_tac)) in + let pretac = tacarg (TacFun([Anonymous],e.field_pre_tac)) in + let posttac = tacarg (TacFun([Anonymous],e.field_post_tac)) in [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok; field_simpl_eq_in_ok;cond_ok;pretac;posttac] diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index fc988a2c5..ea14bc00a 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -1411,7 +1411,7 @@ let () = let name = { mltac_plugin = "ssrmatching_plugin"; mltac_tactic = "ssrpattern"; } in let () = Tacenv.register_ml_tactic name [|mltac|] in let tac = - TacFun ([Some (Id.of_string "pattern")], + TacFun ([Name (Id.of_string "pattern")], TacML (Loc.ghost, { mltac_name = name; mltac_index = 0 }, [])) in let obj () = Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in -- cgit v1.2.3 From 653de32139ecee3114779a5ee2961c58793889e5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 6 Oct 2016 16:59:27 +0200 Subject: Ltac as a plugin. This commit is essentially moving files around. In particular, the corresponding plugin still relies on a mllib file rather than a mlpack one. Otherwise, this causes link-time issues for third-party plugins depending on modules defined in the Ltac plugin. --- Makefile.common | 10 +- Makefile.dev | 7 +- dev/ocamldebug-coq.run | 2 +- ltac/coretactics.ml4 | 329 ----- ltac/evar_tactics.ml | 93 -- ltac/evar_tactics.mli | 19 - ltac/extraargs.ml4 | 389 ------ ltac/extraargs.mli | 78 -- ltac/extratactics.ml4 | 1097 ---------------- ltac/extratactics.mli | 14 - ltac/g_auto.ml4 | 228 ---- ltac/g_class.ml4 | 120 -- ltac/g_eqdecide.ml4 | 27 - ltac/g_ltac.ml4 | 526 -------- ltac/g_obligations.ml4 | 161 --- ltac/g_rewrite.ml4 | 274 ---- ltac/g_tactic.ml4 | 665 ---------- ltac/ltac.mllib | 27 - ltac/pltac.ml | 65 - ltac/pltac.mli | 38 - ltac/pptactic.ml | 1361 -------------------- ltac/pptactic.mli | 67 - ltac/pptacticsig.mli | 81 -- ltac/profile_ltac.ml | 420 ------- ltac/profile_ltac.mli | 48 - ltac/profile_ltac_tactics.ml4 | 40 - ltac/rewrite.ml | 2223 --------------------------------- ltac/rewrite.mli | 117 -- ltac/tacarg.ml | 26 - ltac/tacarg.mli | 27 - ltac/taccoerce.ml | 343 ----- ltac/taccoerce.mli | 96 -- ltac/tacentries.ml | 525 -------- ltac/tacentries.mli | 64 - ltac/tacenv.ml | 143 --- ltac/tacenv.mli | 75 -- ltac/tacexpr.mli | 396 ------ ltac/tacintern.ml | 812 ------------ ltac/tacintern.mli | 64 - ltac/tacinterp.ml | 2157 -------------------------------- ltac/tacinterp.mli | 122 -- ltac/tacsubst.ml | 308 ----- ltac/tacsubst.mli | 30 - ltac/tactic_debug.ml | 422 ------- ltac/tactic_debug.mli | 80 -- ltac/tactic_matching.ml | 377 ------ ltac/tactic_matching.mli | 49 - ltac/tactic_option.ml | 51 - ltac/tactic_option.mli | 15 - ltac/tauto.ml | 279 ----- ltac/tauto.mli | 0 plugins/ltac/Ltac.v | 0 plugins/ltac/coretactics.ml4 | 329 +++++ plugins/ltac/evar_tactics.ml | 93 ++ plugins/ltac/evar_tactics.mli | 19 + plugins/ltac/extraargs.ml4 | 389 ++++++ plugins/ltac/extraargs.mli | 78 ++ plugins/ltac/extratactics.ml4 | 1097 ++++++++++++++++ plugins/ltac/extratactics.mli | 14 + plugins/ltac/g_auto.ml4 | 228 ++++ plugins/ltac/g_class.ml4 | 120 ++ plugins/ltac/g_eqdecide.ml4 | 27 + plugins/ltac/g_ltac.ml4 | 526 ++++++++ plugins/ltac/g_obligations.ml4 | 161 +++ plugins/ltac/g_rewrite.ml4 | 274 ++++ plugins/ltac/g_tactic.ml4 | 665 ++++++++++ plugins/ltac/ltac_plugin.mllib | 27 + plugins/ltac/pltac.ml | 65 + plugins/ltac/pltac.mli | 38 + plugins/ltac/pptactic.ml | 1361 ++++++++++++++++++++ plugins/ltac/pptactic.mli | 67 + plugins/ltac/pptacticsig.mli | 81 ++ plugins/ltac/profile_ltac.ml | 420 +++++++ plugins/ltac/profile_ltac.mli | 48 + plugins/ltac/profile_ltac_tactics.ml4 | 40 + plugins/ltac/rewrite.ml | 2223 +++++++++++++++++++++++++++++++++ plugins/ltac/rewrite.mli | 117 ++ plugins/ltac/tacarg.ml | 26 + plugins/ltac/tacarg.mli | 27 + plugins/ltac/taccoerce.ml | 343 +++++ plugins/ltac/taccoerce.mli | 96 ++ plugins/ltac/tacentries.ml | 525 ++++++++ plugins/ltac/tacentries.mli | 64 + plugins/ltac/tacenv.ml | 143 +++ plugins/ltac/tacenv.mli | 75 ++ plugins/ltac/tacexpr.mli | 396 ++++++ plugins/ltac/tacintern.ml | 812 ++++++++++++ plugins/ltac/tacintern.mli | 64 + plugins/ltac/tacinterp.ml | 2157 ++++++++++++++++++++++++++++++++ plugins/ltac/tacinterp.mli | 122 ++ plugins/ltac/tacsubst.ml | 308 +++++ plugins/ltac/tacsubst.mli | 30 + plugins/ltac/tactic_debug.ml | 422 +++++++ plugins/ltac/tactic_debug.mli | 80 ++ plugins/ltac/tactic_matching.ml | 377 ++++++ plugins/ltac/tactic_matching.mli | 49 + plugins/ltac/tactic_option.ml | 51 + plugins/ltac/tactic_option.mli | 15 + plugins/ltac/tauto.ml | 279 +++++ plugins/ltac/tauto.mli | 0 plugins/ltac/vo.itarget | 1 + theories/Init/Notations.v | 3 + toplevel/coqtop.ml | 2 - 103 files changed, 14982 insertions(+), 14979 deletions(-) delete mode 100644 ltac/coretactics.ml4 delete mode 100644 ltac/evar_tactics.ml delete mode 100644 ltac/evar_tactics.mli delete mode 100644 ltac/extraargs.ml4 delete mode 100644 ltac/extraargs.mli delete mode 100644 ltac/extratactics.ml4 delete mode 100644 ltac/extratactics.mli delete mode 100644 ltac/g_auto.ml4 delete mode 100644 ltac/g_class.ml4 delete mode 100644 ltac/g_eqdecide.ml4 delete mode 100644 ltac/g_ltac.ml4 delete mode 100644 ltac/g_obligations.ml4 delete mode 100644 ltac/g_rewrite.ml4 delete mode 100644 ltac/g_tactic.ml4 delete mode 100644 ltac/ltac.mllib delete mode 100644 ltac/pltac.ml delete mode 100644 ltac/pltac.mli delete mode 100644 ltac/pptactic.ml delete mode 100644 ltac/pptactic.mli delete mode 100644 ltac/pptacticsig.mli delete mode 100644 ltac/profile_ltac.ml delete mode 100644 ltac/profile_ltac.mli delete mode 100644 ltac/profile_ltac_tactics.ml4 delete mode 100644 ltac/rewrite.ml delete mode 100644 ltac/rewrite.mli delete mode 100644 ltac/tacarg.ml delete mode 100644 ltac/tacarg.mli delete mode 100644 ltac/taccoerce.ml delete mode 100644 ltac/taccoerce.mli delete mode 100644 ltac/tacentries.ml delete mode 100644 ltac/tacentries.mli delete mode 100644 ltac/tacenv.ml delete mode 100644 ltac/tacenv.mli delete mode 100644 ltac/tacexpr.mli delete mode 100644 ltac/tacintern.ml delete mode 100644 ltac/tacintern.mli delete mode 100644 ltac/tacinterp.ml delete mode 100644 ltac/tacinterp.mli delete mode 100644 ltac/tacsubst.ml delete mode 100644 ltac/tacsubst.mli delete mode 100644 ltac/tactic_debug.ml delete mode 100644 ltac/tactic_debug.mli delete mode 100644 ltac/tactic_matching.ml delete mode 100644 ltac/tactic_matching.mli delete mode 100644 ltac/tactic_option.ml delete mode 100644 ltac/tactic_option.mli delete mode 100644 ltac/tauto.ml delete mode 100644 ltac/tauto.mli create mode 100644 plugins/ltac/Ltac.v create mode 100644 plugins/ltac/coretactics.ml4 create mode 100644 plugins/ltac/evar_tactics.ml create mode 100644 plugins/ltac/evar_tactics.mli create mode 100644 plugins/ltac/extraargs.ml4 create mode 100644 plugins/ltac/extraargs.mli create mode 100644 plugins/ltac/extratactics.ml4 create mode 100644 plugins/ltac/extratactics.mli create mode 100644 plugins/ltac/g_auto.ml4 create mode 100644 plugins/ltac/g_class.ml4 create mode 100644 plugins/ltac/g_eqdecide.ml4 create mode 100644 plugins/ltac/g_ltac.ml4 create mode 100644 plugins/ltac/g_obligations.ml4 create mode 100644 plugins/ltac/g_rewrite.ml4 create mode 100644 plugins/ltac/g_tactic.ml4 create mode 100644 plugins/ltac/ltac_plugin.mllib create mode 100644 plugins/ltac/pltac.ml create mode 100644 plugins/ltac/pltac.mli create mode 100644 plugins/ltac/pptactic.ml create mode 100644 plugins/ltac/pptactic.mli create mode 100644 plugins/ltac/pptacticsig.mli create mode 100644 plugins/ltac/profile_ltac.ml create mode 100644 plugins/ltac/profile_ltac.mli create mode 100644 plugins/ltac/profile_ltac_tactics.ml4 create mode 100644 plugins/ltac/rewrite.ml create mode 100644 plugins/ltac/rewrite.mli create mode 100644 plugins/ltac/tacarg.ml create mode 100644 plugins/ltac/tacarg.mli create mode 100644 plugins/ltac/taccoerce.ml create mode 100644 plugins/ltac/taccoerce.mli create mode 100644 plugins/ltac/tacentries.ml create mode 100644 plugins/ltac/tacentries.mli create mode 100644 plugins/ltac/tacenv.ml create mode 100644 plugins/ltac/tacenv.mli create mode 100644 plugins/ltac/tacexpr.mli create mode 100644 plugins/ltac/tacintern.ml create mode 100644 plugins/ltac/tacintern.mli create mode 100644 plugins/ltac/tacinterp.ml create mode 100644 plugins/ltac/tacinterp.mli create mode 100644 plugins/ltac/tacsubst.ml create mode 100644 plugins/ltac/tacsubst.mli create mode 100644 plugins/ltac/tactic_debug.ml create mode 100644 plugins/ltac/tactic_debug.mli create mode 100644 plugins/ltac/tactic_matching.ml create mode 100644 plugins/ltac/tactic_matching.mli create mode 100644 plugins/ltac/tactic_option.ml create mode 100644 plugins/ltac/tactic_option.mli create mode 100644 plugins/ltac/tauto.ml create mode 100644 plugins/ltac/tauto.mli create mode 100644 plugins/ltac/vo.itarget (limited to 'plugins') diff --git a/Makefile.common b/Makefile.common index 2cf4d0169..df705034e 100644 --- a/Makefile.common +++ b/Makefile.common @@ -55,14 +55,14 @@ MKDIR:=install -d CORESRCDIRS:=\ config lib kernel intf kernel/byterun library \ engine pretyping interp proofs parsing printing \ - tactics vernac stm toplevel ltac + tactics vernac stm toplevel PLUGINDIRS:=\ omega romega micromega quote \ setoid_ring extraction fourier \ cc funind firstorder derive \ rtauto nsatz syntax decl_mode btauto \ - ssrmatching + ssrmatching ltac SRCDIRS:=\ $(CORESRCDIRS) \ @@ -77,14 +77,13 @@ BYTERUN:=$(addprefix kernel/byterun/, \ coq_fix_code.o coq_memory.o coq_values.o coq_interp.o ) # LINK ORDER: -# Beware that highparsing.cma should appear before ltac.cma # respecting this order is useful for developers that want to load or link # the libraries directly CORECMA:=lib/clib.cma lib/lib.cma kernel/kernel.cma library/library.cma \ engine/engine.cma pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \ parsing/parsing.cma printing/printing.cma tactics/tactics.cma vernac/vernac.cma \ - stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma ltac/ltac.cma + stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma TOPLOOPCMA:=stm/proofworkertop.cma stm/tacworkertop.cma stm/queryworkertop.cma @@ -120,6 +119,7 @@ OTHERSYNTAXCMO:=$(addprefix plugins/syntax/, \ string_syntax_plugin.cmo ) DECLMODECMO:=plugins/decl_mode/decl_mode_plugin.cmo DERIVECMO:=plugins/derive/derive_plugin.cmo +LTACCMO:=plugins/ltac/ltac_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo PLUGINSCMO:=$(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \ @@ -127,7 +127,7 @@ PLUGINSCMO:=$(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \ $(FOURIERCMO) $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ $(FUNINDCMO) $(NSATZCMO) $(NATSYNTAXCMO) $(OTHERSYNTAXCMO) \ - $(DERIVECMO) $(SSRMATCHINGCMO) + $(DERIVECMO) $(SSRMATCHINGCMO) $(LTACCMO) ifeq ($(HASNATDYNLINK)-$(BEST),false-opt) STATICPLUGINS:=$(PLUGINSCMO) diff --git a/Makefile.dev b/Makefile.dev index 8c1812da1..ea6b8b919 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -121,10 +121,9 @@ pretyping: pretyping/pretyping.cma highparsing: parsing/highparsing.cma stm: stm/stm.cma toplevel: toplevel/toplevel.cma -ltac: ltac/ltac.cma .PHONY: lib kernel byterun library proofs tactics interp parsing pretyping -.PHONY: engine highparsing stm toplevel ltac +.PHONY: engine highparsing stm toplevel ###################### ### 3) theories files @@ -183,6 +182,7 @@ RTAUTOVO:=$(filter plugins/rtauto/%, $(PLUGINSVO)) EXTRACTIONVO:=$(filter plugins/extraction/%, $(PLUGINSVO)) CCVO:= DERIVEVO:=$(filter plugins/derive/%, $(PLUGINSVO)) +LTACVO:=$(filter plugins/ltac/%, $(PLUGINSVO)) omega: $(OMEGAVO) $(OMEGACMO) $(ROMEGAVO) $(ROMEGACMO) micromega: $(MICROMEGAVO) $(MICROMEGACMO) $(CSDPCERT) @@ -194,9 +194,10 @@ funind: $(FUNINDCMO) $(FUNINDVO) cc: $(CCVO) $(CCCMO) rtauto: $(RTAUTOVO) $(RTAUTOCMO) btauto: $(BTAUTOVO) $(BTAUTOCMO) +ltac: $(LTACVO) $(LTACCMO) .PHONY: omega micromega setoid_ring nsatz extraction -.PHONY: fourier funind cc rtauto btauto +.PHONY: fourier funind cc rtauto btauto ltac ################################# ### Misc other development rules diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index 46caca8d6..23ad1fc01 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -32,6 +32,6 @@ exec $OCAMLDEBUG \ -I $COQTOP/plugins/ring -I $COQTOP/plugins/romega \ -I $COQTOP/plugins/rtauto -I $COQTOP/plugins/setoid_ring \ -I $COQTOP/plugins/subtac -I $COQTOP/plugins/syntax \ - -I $COQTOP/plugins/xml \ + -I $COQTOP/plugins/xml -I $COQTOP/plugins/ltac \ -I $COQTOP/ide \ "$@" diff --git a/ltac/coretactics.ml4 b/ltac/coretactics.ml4 deleted file mode 100644 index 28ff6df83..000000000 --- a/ltac/coretactics.ml4 +++ /dev/null @@ -1,329 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ Tactics.intros_reflexivity ] -END - -TACTIC EXTEND exact - [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ] -END - -TACTIC EXTEND assumption - [ "assumption" ] -> [ Tactics.assumption ] -END - -TACTIC EXTEND etransitivity - [ "etransitivity" ] -> [ Tactics.intros_transitivity None ] -END - -TACTIC EXTEND cut - [ "cut" constr(c) ] -> [ Tactics.cut c ] -END - -TACTIC EXTEND exact_no_check - [ "exact_no_check" constr(c) ] -> [ Tactics.exact_no_check c ] -END - -TACTIC EXTEND vm_cast_no_check - [ "vm_cast_no_check" constr(c) ] -> [ Tactics.vm_cast_no_check c ] -END - -TACTIC EXTEND native_cast_no_check - [ "native_cast_no_check" constr(c) ] -> [ Tactics.native_cast_no_check c ] -END - -TACTIC EXTEND casetype - [ "casetype" constr(c) ] -> [ Tactics.case_type c ] -END - -TACTIC EXTEND elimtype - [ "elimtype" constr(c) ] -> [ Tactics.elim_type c ] -END - -TACTIC EXTEND lapply - [ "lapply" constr(c) ] -> [ Tactics.cut_and_apply c ] -END - -TACTIC EXTEND transitivity - [ "transitivity" constr(c) ] -> [ Tactics.intros_transitivity (Some c) ] -END - -(** Left *) - -TACTIC EXTEND left - [ "left" ] -> [ Tactics.left_with_bindings false NoBindings ] -END - -TACTIC EXTEND eleft - [ "eleft" ] -> [ Tactics.left_with_bindings true NoBindings ] -END - -TACTIC EXTEND left_with - [ "left" "with" bindings(bl) ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.left_with_bindings false bl) - ] -END - -TACTIC EXTEND eleft_with - [ "eleft" "with" bindings(bl) ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.left_with_bindings true bl) - ] -END - -(** Right *) - -TACTIC EXTEND right - [ "right" ] -> [ Tactics.right_with_bindings false NoBindings ] -END - -TACTIC EXTEND eright - [ "eright" ] -> [ Tactics.right_with_bindings true NoBindings ] -END - -TACTIC EXTEND right_with - [ "right" "with" bindings(bl) ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.right_with_bindings false bl) - ] -END - -TACTIC EXTEND eright_with - [ "eright" "with" bindings(bl) ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.right_with_bindings true bl) - ] -END - -(** Constructor *) - -TACTIC EXTEND constructor - [ "constructor" ] -> [ Tactics.any_constructor false None ] -| [ "constructor" int_or_var(i) ] -> [ - Tactics.constructor_tac false None i NoBindings - ] -| [ "constructor" int_or_var(i) "with" bindings(bl) ] -> [ - let tac bl = Tactics.constructor_tac false None i bl in - Tacticals.New.tclDELAYEDWITHHOLES false bl tac - ] -END - -TACTIC EXTEND econstructor - [ "econstructor" ] -> [ Tactics.any_constructor true None ] -| [ "econstructor" int_or_var(i) ] -> [ - Tactics.constructor_tac true None i NoBindings - ] -| [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> [ - let tac bl = Tactics.constructor_tac true None i bl in - Tacticals.New.tclDELAYEDWITHHOLES true bl tac - ] -END - -(** Specialize *) - -TACTIC EXTEND specialize - [ "specialize" constr_with_bindings(c) ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> Tactics.specialize c None) - ] -| [ "specialize" constr_with_bindings(c) "as" intropattern(ipat) ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> Tactics.specialize c (Some ipat)) - ] -END - -TACTIC EXTEND symmetry - [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ] -END - -TACTIC EXTEND symmetry_in -| [ "symmetry" "in" in_clause(cl) ] -> [ Tactics.intros_symmetry cl ] -END - -(** Split *) - -let rec delayed_list = function -| [] -> { Tacexpr.delayed = fun _ sigma -> Sigma.here [] sigma } -| x :: l -> - { Tacexpr.delayed = fun env sigma -> - let Sigma (x, sigma, p) = x.Tacexpr.delayed env sigma in - let Sigma (l, sigma, q) = (delayed_list l).Tacexpr.delayed env sigma in - Sigma (x :: l, sigma, p +> q) } - -TACTIC EXTEND split - [ "split" ] -> [ Tactics.split_with_bindings false [NoBindings] ] -END - -TACTIC EXTEND esplit - [ "esplit" ] -> [ Tactics.split_with_bindings true [NoBindings] ] -END - -TACTIC EXTEND split_with - [ "split" "with" bindings(bl) ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.split_with_bindings false [bl]) - ] -END - -TACTIC EXTEND esplit_with - [ "esplit" "with" bindings(bl) ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.split_with_bindings true [bl]) - ] -END - -TACTIC EXTEND exists - [ "exists" ] -> [ Tactics.split_with_bindings false [NoBindings] ] -| [ "exists" ne_bindings_list_sep(bll, ",") ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES false (delayed_list bll) (fun bll -> Tactics.split_with_bindings false bll) - ] -END - -TACTIC EXTEND eexists - [ "eexists" ] -> [ Tactics.split_with_bindings true [NoBindings] ] -| [ "eexists" ne_bindings_list_sep(bll, ",") ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES true (delayed_list bll) (fun bll -> Tactics.split_with_bindings true bll) - ] -END - -(** Intro *) - -TACTIC EXTEND intros_until - [ "intros" "until" quantified_hypothesis(h) ] -> [ Tactics.intros_until h ] -END - -TACTIC EXTEND intro -| [ "intro" ] -> [ Tactics.intro_move None MoveLast ] -| [ "intro" ident(id) ] -> [ Tactics.intro_move (Some id) MoveLast ] -| [ "intro" ident(id) "at" "top" ] -> [ Tactics.intro_move (Some id) MoveFirst ] -| [ "intro" ident(id) "at" "bottom" ] -> [ Tactics.intro_move (Some id) MoveLast ] -| [ "intro" ident(id) "after" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveAfter h) ] -| [ "intro" ident(id) "before" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveBefore h) ] -| [ "intro" "at" "top" ] -> [ Tactics.intro_move None MoveFirst ] -| [ "intro" "at" "bottom" ] -> [ Tactics.intro_move None MoveLast ] -| [ "intro" "after" hyp(h) ] -> [ Tactics.intro_move None (MoveAfter h) ] -| [ "intro" "before" hyp(h) ] -> [ Tactics.intro_move None (MoveBefore h) ] -END - -(** Move *) - -TACTIC EXTEND move - [ "move" hyp(id) "at" "top" ] -> [ Tactics.move_hyp id MoveFirst ] -| [ "move" hyp(id) "at" "bottom" ] -> [ Tactics.move_hyp id MoveLast ] -| [ "move" hyp(id) "after" hyp(h) ] -> [ Tactics.move_hyp id (MoveAfter h) ] -| [ "move" hyp(id) "before" hyp(h) ] -> [ Tactics.move_hyp id (MoveBefore h) ] -END - -(** Rename *) - -TACTIC EXTEND rename -| [ "rename" ne_rename_list_sep(ids, ",") ] -> [ Tactics.rename_hyp ids ] -END - -(** Revert *) - -TACTIC EXTEND revert - [ "revert" ne_hyp_list(hl) ] -> [ Tactics.revert hl ] -END - -(** Simple induction / destruct *) - -TACTIC EXTEND simple_induction - [ "simple" "induction" quantified_hypothesis(h) ] -> [ Tactics.simple_induct h ] -END - -TACTIC EXTEND simple_destruct - [ "simple" "destruct" quantified_hypothesis(h) ] -> [ Tactics.simple_destruct h ] -END - -(** Double induction *) - -TACTIC EXTEND double_induction - [ "double" "induction" quantified_hypothesis(h1) quantified_hypothesis(h2) ] -> - [ Elim.h_double_induction h1 h2 ] -END - -(* Admit *) - -TACTIC EXTEND admit - [ "admit" ] -> [ Proofview.give_up ] -END - -(* Fix *) - -TACTIC EXTEND fix - [ "fix" natural(n) ] -> [ Tactics.fix None n ] -| [ "fix" ident(id) natural(n) ] -> [ Tactics.fix (Some id) n ] -END - -(* Cofix *) - -TACTIC EXTEND cofix - [ "cofix" ] -> [ Tactics.cofix None ] -| [ "cofix" ident(id) ] -> [ Tactics.cofix (Some id) ] -END - -(* Clear *) - -TACTIC EXTEND clear - [ "clear" hyp_list(ids) ] -> [ - if List.is_empty ids then Tactics.keep [] - else Tactics.clear ids - ] -| [ "clear" "-" ne_hyp_list(ids) ] -> [ Tactics.keep ids ] -END - -(* Clearbody *) - -TACTIC EXTEND clearbody - [ "clearbody" ne_hyp_list(ids) ] -> [ Tactics.clear_body ids ] -END - -(* Generalize dependent *) - -TACTIC EXTEND generalize_dependent - [ "generalize" "dependent" constr(c) ] -> [ Tactics.generalize_dep c ] -END - -(* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) - -open Tacexpr - -let initial_atomic () = - let dloc = Loc.ghost in - let nocl = {onhyps=Some[];concl_occs=AllOccurrences} in - let iter (s, t) = - let body = TacAtom (dloc, t) in - Tacenv.register_ltac false false (Id.of_string s) body - in - let () = List.iter iter - [ "red", TacReduce(Red false,nocl); - "hnf", TacReduce(Hnf,nocl); - "simpl", TacReduce(Simpl (Redops.all_flags,None),nocl); - "compute", TacReduce(Cbv Redops.all_flags,nocl); - "intros", TacIntroPattern (false,[]); - ] - in - let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in - List.iter iter - [ "idtac",TacId []; - "fail", TacFail(TacLocal,ArgArg 0,[]); - "fresh", TacArg(dloc,TacFreshId []) - ] - -let () = Mltop.declare_cache_obj initial_atomic "coretactics" diff --git a/ltac/evar_tactics.ml b/ltac/evar_tactics.ml deleted file mode 100644 index c5b26e6d5..000000000 --- a/ltac/evar_tactics.ml +++ /dev/null @@ -1,93 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let sigma = gl.sigma in - let evl = - match ido with - ConclLocation () -> evar_list (pf_concl gl) - | HypLocation (id,hloc) -> - let decl = Environ.lookup_named_val id (Goal.V82.hyps sigma (sig_it gl)) in - match hloc with - InHyp -> - (match decl with - | LocalAssum (_,typ) -> evar_list typ - | _ -> error - "Please be more specific: in type or value?") - | InHypTypeOnly -> - evar_list (NamedDecl.get_type decl) - | InHypValueOnly -> - (match decl with - | LocalDef (_,body,_) -> evar_list body - | _ -> error "Not a defined hypothesis.") in - if List.length evl < n then - error "Not enough uninstantiated existential variables."; - if n <= 0 then error "Incorrect existential variable index."; - let evk,_ = List.nth evl (n-1) in - instantiate_evar evk c sigma gl - end - -let instantiate_tac_by_name id c = - Proofview.V82.tactic begin fun gl -> - let sigma = gl.sigma in - let evk = - try Evd.evar_key id sigma - with Not_found -> error "Unknown existential variable." in - instantiate_evar evk c sigma gl - end - -let let_evar name typ = - let src = (Loc.ghost,Evar_kinds.GoalEvar) in - Proofview.Goal.s_enter { s_enter = begin fun gl -> - let sigma = Tacmach.New.project gl in - let env = Proofview.Goal.env gl in - let sigma = ref sigma in - let _ = Typing.e_sort_of env sigma typ in - let sigma = Sigma.Unsafe.of_evar_map !sigma in - let id = match name with - | Names.Anonymous -> - let id = Namegen.id_of_name_using_hdchar env typ name in - Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env)) - | Names.Name id -> id - in - let Sigma (evar, sigma, p) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in - let tac = - (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere) - in - Sigma (tac, sigma, p) - end } diff --git a/ltac/evar_tactics.mli b/ltac/evar_tactics.mli deleted file mode 100644 index e67540c05..000000000 --- a/ltac/evar_tactics.mli +++ /dev/null @@ -1,19 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Tacinterp.interp_sign * Glob_term.glob_constr -> - (Id.t * hyp_location_flag, unit) location -> unit Proofview.tactic - -val instantiate_tac_by_name : Id.t -> - Tacinterp.interp_sign * Glob_term.glob_constr -> unit Proofview.tactic - -val let_evar : Name.t -> Term.types -> unit Proofview.tactic diff --git a/ltac/extraargs.ml4 b/ltac/extraargs.ml4 deleted file mode 100644 index 53b726432..000000000 --- a/ltac/extraargs.ml4 +++ /dev/null @@ -1,389 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* " - -let pr_orient _prc _prlc _prt = function - | true -> Pp.mt () - | false -> Pp.str " <-" - -ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient -| [ "->" ] -> [ true ] -| [ "<-" ] -> [ false ] -| [ ] -> [ true ] -END - -let pr_int _ _ _ i = Pp.int i - -let _natural = Pcoq.Prim.natural - -ARGUMENT EXTEND natural TYPED AS int PRINTED BY pr_int -| [ _natural(i) ] -> [ i ] -END - -let pr_orient = pr_orient () () () - - -let pr_int_list = Pp.pr_sequence Pp.int -let pr_int_list_full _prc _prlc _prt l = pr_int_list l - -let pr_occurrences _prc _prlc _prt l = - match l with - | ArgArg x -> pr_int_list x - | ArgVar (loc, id) -> Nameops.pr_id id - -let occurrences_of = function - | [] -> NoOccurrences - | n::_ as nl when n < 0 -> AllOccurrencesBut (List.map abs nl) - | nl -> - if List.exists (fun n -> n < 0) nl then - CErrors.error "Illegal negative occurrence number."; - OnlyOccurrences nl - -let coerce_to_int v = match Value.to_int v with - | None -> raise (CannotCoerceTo "an integer") - | Some n -> n - -let int_list_of_VList v = match Value.to_list v with -| Some l -> List.map (fun n -> coerce_to_int n) l -| _ -> raise (CannotCoerceTo "an integer") - -let interp_occs ist gl l = - match l with - | ArgArg x -> x - | ArgVar (_,id as locid) -> - (try int_list_of_VList (Id.Map.find id ist.lfun) - with Not_found | CannotCoerceTo _ -> [interp_int ist locid]) -let interp_occs ist gl l = - Tacmach.project gl , interp_occs ist gl l - -let glob_occs ist l = l - -let subst_occs evm l = l - -ARGUMENT EXTEND occurrences - TYPED AS int list - PRINTED BY pr_int_list_full - - INTERPRETED BY interp_occs - GLOBALIZED BY glob_occs - SUBSTITUTED BY subst_occs - - RAW_PRINTED BY pr_occurrences - GLOB_PRINTED BY pr_occurrences - -| [ ne_integer_list(l) ] -> [ ArgArg l ] -| [ var(id) ] -> [ ArgVar id ] -END - -let pr_occurrences = pr_occurrences () () () - -let pr_gen prc _prlc _prtac c = prc c - -let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob - -let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) - -let glob_glob = Tacintern.intern_constr - -let pr_lconstr _ prc _ c = prc c - -let subst_glob = Tacsubst.subst_glob_constr_and_expr - -ARGUMENT EXTEND glob - PRINTED BY pr_globc - - INTERPRETED BY interp_glob - GLOBALIZED BY glob_glob - SUBSTITUTED BY subst_glob - - RAW_PRINTED BY pr_gen - GLOB_PRINTED BY pr_gen - [ constr(c) ] -> [ c ] -END - -let l_constr = Pcoq.Constr.lconstr - -ARGUMENT EXTEND lconstr - TYPED AS constr - PRINTED BY pr_lconstr - [ l_constr(c) ] -> [ c ] -END - -ARGUMENT EXTEND lglob - TYPED AS glob - PRINTED BY pr_globc - - INTERPRETED BY interp_glob - GLOBALIZED BY glob_glob - SUBSTITUTED BY subst_glob - - RAW_PRINTED BY pr_gen - GLOB_PRINTED BY pr_gen - [ lconstr(c) ] -> [ c ] -END - -let interp_casted_constr ist gl c = - interp_constr_gen (Pretyping.OfType (pf_concl gl)) ist (pf_env gl) (project gl) c - -ARGUMENT EXTEND casted_constr - TYPED AS constr - PRINTED BY pr_gen - INTERPRETED BY interp_casted_constr - [ constr(c) ] -> [ c ] -END - -type 'id gen_place= ('id * hyp_location_flag,unit) location - -type loc_place = Id.t Loc.located gen_place -type place = Id.t gen_place - -let pr_gen_place pr_id = function - ConclLocation () -> Pp.mt () - | HypLocation (id,InHyp) -> str "in " ++ pr_id id - | HypLocation (id,InHypTypeOnly) -> - str "in (Type of " ++ pr_id id ++ str ")" - | HypLocation (id,InHypValueOnly) -> - str "in (Value of " ++ pr_id id ++ str ")" - -let pr_loc_place _ _ _ = pr_gen_place (fun (_,id) -> Nameops.pr_id id) -let pr_place _ _ _ = pr_gen_place Nameops.pr_id -let pr_hloc = pr_loc_place () () () - -let intern_place ist = function - ConclLocation () -> ConclLocation () - | HypLocation (id,hl) -> HypLocation (Tacintern.intern_hyp ist id,hl) - -let interp_place ist env sigma = function - ConclLocation () -> ConclLocation () - | HypLocation (id,hl) -> HypLocation (Tacinterp.interp_hyp ist env sigma id,hl) - -let interp_place ist gl p = - Tacmach.project gl , interp_place ist (Tacmach.pf_env gl) (Tacmach.project gl) p - -let subst_place subst pl = pl - -ARGUMENT EXTEND hloc - PRINTED BY pr_place - INTERPRETED BY interp_place - GLOBALIZED BY intern_place - SUBSTITUTED BY subst_place - RAW_PRINTED BY pr_loc_place - GLOB_PRINTED BY pr_loc_place - [ ] -> - [ ConclLocation () ] - | [ "in" "|-" "*" ] -> - [ ConclLocation () ] -| [ "in" ident(id) ] -> - [ HypLocation ((Loc.ghost,id),InHyp) ] -| [ "in" "(" "Type" "of" ident(id) ")" ] -> - [ HypLocation ((Loc.ghost,id),InHypTypeOnly) ] -| [ "in" "(" "Value" "of" ident(id) ")" ] -> - [ HypLocation ((Loc.ghost,id),InHypValueOnly) ] - - END - -let pr_rename _ _ _ (n, m) = Nameops.pr_id n ++ str " into " ++ Nameops.pr_id m - -ARGUMENT EXTEND rename - TYPED AS ident * ident - PRINTED BY pr_rename -| [ ident(n) "into" ident(m) ] -> [ (n, m) ] -END - -(* Julien: Mise en commun des differentes version de replace with in by *) - -let pr_by_arg_tac _prc _prlc prtac opt_c = - match opt_c with - | None -> mt () - | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Ppextend.E) t) - -ARGUMENT EXTEND by_arg_tac - TYPED AS tactic_opt - PRINTED BY pr_by_arg_tac -| [ "by" tactic3(c) ] -> [ Some c ] -| [ ] -> [ None ] -END - -let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c - -let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl -let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl -let in_clause' = Pltac.in_clause - -ARGUMENT EXTEND in_clause - TYPED AS clause_dft_concl - PRINTED BY pr_in_top_clause - RAW_TYPED AS clause_dft_concl - RAW_PRINTED BY pr_in_clause - GLOB_TYPED AS clause_dft_concl - GLOB_PRINTED BY pr_in_clause -| [ in_clause'(cl) ] -> [ cl ] -END - -(* spiwack: the print functions are incomplete, but I don't know what they are - used for *) -let pr_r_nat_field natf = - str "nat " ++ - match natf with - | Retroknowledge.NatType -> str "type" - | Retroknowledge.NatPlus -> str "plus" - | Retroknowledge.NatTimes -> str "times" - -let pr_r_n_field nf = - str "binary N " ++ - match nf with - | Retroknowledge.NPositive -> str "positive" - | Retroknowledge.NType -> str "type" - | Retroknowledge.NTwice -> str "twice" - | Retroknowledge.NTwicePlusOne -> str "twice plus one" - | Retroknowledge.NPhi -> str "phi" - | Retroknowledge.NPhiInv -> str "phi inv" - | Retroknowledge.NPlus -> str "plus" - | Retroknowledge.NTimes -> str "times" - -let pr_r_int31_field i31f = - str "int31 " ++ - match i31f with - | Retroknowledge.Int31Bits -> str "bits" - | Retroknowledge.Int31Type -> str "type" - | Retroknowledge.Int31Twice -> str "twice" - | Retroknowledge.Int31TwicePlusOne -> str "twice plus one" - | Retroknowledge.Int31Phi -> str "phi" - | Retroknowledge.Int31PhiInv -> str "phi inv" - | Retroknowledge.Int31Plus -> str "plus" - | Retroknowledge.Int31Times -> str "times" - | Retroknowledge.Int31Constructor -> assert false - | Retroknowledge.Int31PlusC -> str "plusc" - | Retroknowledge.Int31PlusCarryC -> str "pluscarryc" - | Retroknowledge.Int31Minus -> str "minus" - | Retroknowledge.Int31MinusC -> str "minusc" - | Retroknowledge.Int31MinusCarryC -> str "minuscarryc" - | Retroknowledge.Int31TimesC -> str "timesc" - | Retroknowledge.Int31Div21 -> str "div21" - | Retroknowledge.Int31Div -> str "div" - | Retroknowledge.Int31Diveucl -> str "diveucl" - | Retroknowledge.Int31AddMulDiv -> str "addmuldiv" - | Retroknowledge.Int31Compare -> str "compare" - | Retroknowledge.Int31Head0 -> str "head0" - | Retroknowledge.Int31Tail0 -> str "tail0" - | Retroknowledge.Int31Lor -> str "lor" - | Retroknowledge.Int31Land -> str "land" - | Retroknowledge.Int31Lxor -> str "lxor" - -let pr_retroknowledge_field f = - match f with - (* | Retroknowledge.KEq -> str "equality" - | Retroknowledge.KNat natf -> pr_r_nat_field () () () natf - | Retroknowledge.KN nf -> pr_r_n_field () () () nf *) - | Retroknowledge.KInt31 (group, i31f) -> (pr_r_int31_field i31f) ++ - spc () ++ str "in " ++ qs group - -VERNAC ARGUMENT EXTEND retroknowledge_nat -PRINTED BY pr_r_nat_field -| [ "nat" "type" ] -> [ Retroknowledge.NatType ] -| [ "nat" "plus" ] -> [ Retroknowledge.NatPlus ] -| [ "nat" "times" ] -> [ Retroknowledge.NatTimes ] -END - - -VERNAC ARGUMENT EXTEND retroknowledge_binary_n -PRINTED BY pr_r_n_field -| [ "binary" "N" "positive" ] -> [ Retroknowledge.NPositive ] -| [ "binary" "N" "type" ] -> [ Retroknowledge.NType ] -| [ "binary" "N" "twice" ] -> [ Retroknowledge.NTwice ] -| [ "binary" "N" "twice" "plus" "one" ] -> [ Retroknowledge.NTwicePlusOne ] -| [ "binary" "N" "phi" ] -> [ Retroknowledge.NPhi ] -| [ "binary" "N" "phi" "inv" ] -> [ Retroknowledge.NPhiInv ] -| [ "binary" "N" "plus" ] -> [ Retroknowledge.NPlus ] -| [ "binary" "N" "times" ] -> [ Retroknowledge.NTimes ] -END - -VERNAC ARGUMENT EXTEND retroknowledge_int31 -PRINTED BY pr_r_int31_field -| [ "int31" "bits" ] -> [ Retroknowledge.Int31Bits ] -| [ "int31" "type" ] -> [ Retroknowledge.Int31Type ] -| [ "int31" "twice" ] -> [ Retroknowledge.Int31Twice ] -| [ "int31" "twice" "plus" "one" ] -> [ Retroknowledge.Int31TwicePlusOne ] -| [ "int31" "phi" ] -> [ Retroknowledge.Int31Phi ] -| [ "int31" "phi" "inv" ] -> [ Retroknowledge.Int31PhiInv ] -| [ "int31" "plus" ] -> [ Retroknowledge.Int31Plus ] -| [ "int31" "plusc" ] -> [ Retroknowledge.Int31PlusC ] -| [ "int31" "pluscarryc" ] -> [ Retroknowledge.Int31PlusCarryC ] -| [ "int31" "minus" ] -> [ Retroknowledge.Int31Minus ] -| [ "int31" "minusc" ] -> [ Retroknowledge.Int31MinusC ] -| [ "int31" "minuscarryc" ] -> [ Retroknowledge.Int31MinusCarryC ] -| [ "int31" "times" ] -> [ Retroknowledge.Int31Times ] -| [ "int31" "timesc" ] -> [ Retroknowledge.Int31TimesC ] -| [ "int31" "div21" ] -> [ Retroknowledge.Int31Div21 ] -| [ "int31" "div" ] -> [ Retroknowledge.Int31Div ] -| [ "int31" "diveucl" ] -> [ Retroknowledge.Int31Diveucl ] -| [ "int31" "addmuldiv" ] -> [ Retroknowledge.Int31AddMulDiv ] -| [ "int31" "compare" ] -> [ Retroknowledge.Int31Compare ] -| [ "int31" "head0" ] -> [ Retroknowledge.Int31Head0 ] -| [ "int31" "tail0" ] -> [ Retroknowledge.Int31Tail0 ] -| [ "int31" "lor" ] -> [ Retroknowledge.Int31Lor ] -| [ "int31" "land" ] -> [ Retroknowledge.Int31Land ] -| [ "int31" "lxor" ] -> [ Retroknowledge.Int31Lxor ] -END - -VERNAC ARGUMENT EXTEND retroknowledge_field -PRINTED BY pr_retroknowledge_field -(*| [ "equality" ] -> [ Retroknowledge.KEq ] -| [ retroknowledge_nat(n)] -> [ Retroknowledge.KNat n ] -| [ retroknowledge_binary_n (n)] -> [ Retroknowledge.KN n ]*) -| [ retroknowledge_int31 (i) "in" string(g)] -> [ Retroknowledge.KInt31(g,i) ] -END diff --git a/ltac/extraargs.mli b/ltac/extraargs.mli deleted file mode 100644 index b12187e18..000000000 --- a/ltac/extraargs.mli +++ /dev/null @@ -1,78 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.std_ppcmds - -val wit_rename : (Id.t * Id.t) Genarg.uniform_genarg_type - -val occurrences : (int list or_var) Pcoq.Gram.entry -val wit_occurrences : (int list or_var, int list or_var, int list) Genarg.genarg_type -val pr_occurrences : int list or_var -> Pp.std_ppcmds -val occurrences_of : int list -> Locus.occurrences - -val wit_natural : int Genarg.uniform_genarg_type - -val wit_glob : - (constr_expr, - Tacexpr.glob_constr_and_expr, - Tacinterp.interp_sign * glob_constr) Genarg.genarg_type - -val wit_lglob : - (constr_expr, - Tacexpr.glob_constr_and_expr, - Tacinterp.interp_sign * glob_constr) Genarg.genarg_type - -val wit_lconstr : - (constr_expr, - Tacexpr.glob_constr_and_expr, - Constr.t) Genarg.genarg_type - -val wit_casted_constr : - (constr_expr, - Tacexpr.glob_constr_and_expr, - Constr.t) Genarg.genarg_type - -val glob : constr_expr Pcoq.Gram.entry -val lglob : constr_expr Pcoq.Gram.entry - -type 'id gen_place= ('id * Locus.hyp_location_flag,unit) location - -type loc_place = Id.t Loc.located gen_place -type place = Id.t gen_place - -val wit_hloc : (loc_place, loc_place, place) Genarg.genarg_type -val hloc : loc_place Pcoq.Gram.entry -val pr_hloc : loc_place -> Pp.std_ppcmds - -val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry -val wit_by_arg_tac : - (raw_tactic_expr option, - glob_tactic_expr option, - Geninterp.Val.t option) Genarg.genarg_type - -val pr_by_arg_tac : - (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) -> - raw_tactic_expr option -> Pp.std_ppcmds - -(** Spiwack: Primitive for retroknowledge registration *) - -val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry -val wit_retroknowledge_field : (Retroknowledge.field, unit, unit) Genarg.genarg_type - -val wit_in_clause : - (Id.t Loc.located Locus.clause_expr, - Id.t Loc.located Locus.clause_expr, - Id.t Locus.clause_expr) Genarg.genarg_type diff --git a/ltac/extratactics.ml4 b/ltac/extratactics.ml4 deleted file mode 100644 index 1223f6eb4..000000000 --- a/ltac/extratactics.ml4 +++ /dev/null @@ -1,1097 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* replace_in_clause_maybe_by c1 c2 cl (Option.map (Tacinterp.tactic_of_value ist) tac)) - -let replace_term ist dir_opt c cl = - with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl) - -let clause = Pltac.clause_dft_concl - -TACTIC EXTEND replace - ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] --> [ replace_in_clause_maybe_by ist c1 c2 cl tac ] -END - -TACTIC EXTEND replace_term_left - [ "replace" "->" uconstr(c) clause(cl) ] - -> [ replace_term ist (Some true) c cl ] -END - -TACTIC EXTEND replace_term_right - [ "replace" "<-" uconstr(c) clause(cl) ] - -> [ replace_term ist (Some false) c cl ] -END - -TACTIC EXTEND replace_term - [ "replace" uconstr(c) clause(cl) ] - -> [ replace_term ist None c cl ] -END - -let induction_arg_of_quantified_hyp = function - | AnonHyp n -> None,ElimOnAnonHyp n - | NamedHyp id -> None,ElimOnIdent (Loc.ghost,id) - -(* Versions *_main must come first!! so that "1" is interpreted as a - ElimOnAnonHyp and not as a "constr", and "id" is interpreted as a - ElimOnIdent and not as "constr" *) - -let mytclWithHoles tac with_evars c = - Proofview.Goal.enter { enter = begin fun gl -> - let env = Tacmach.New.pf_env gl in - let sigma = Tacmach.New.project gl in - let sigma',c = Tactics.force_destruction_arg with_evars env sigma c in - Tacticals.New.tclWITHHOLES with_evars (tac with_evars (Some c)) sigma' - end } - -let elimOnConstrWithHoles tac with_evars c = - Tacticals.New.tclDELAYEDWITHHOLES with_evars c - (fun c -> tac with_evars (Some (None,ElimOnConstr c))) - -TACTIC EXTEND simplify_eq - [ "simplify_eq" ] -> [ dEq false None ] -| [ "simplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq false c ] -END -TACTIC EXTEND esimplify_eq -| [ "esimplify_eq" ] -> [ dEq true None ] -| [ "esimplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq true c ] -END - -let discr_main c = elimOnConstrWithHoles discr_tac false c - -TACTIC EXTEND discriminate -| [ "discriminate" ] -> [ discr_tac false None ] -| [ "discriminate" destruction_arg(c) ] -> - [ mytclWithHoles discr_tac false c ] -END -TACTIC EXTEND ediscriminate -| [ "ediscriminate" ] -> [ discr_tac true None ] -| [ "ediscriminate" destruction_arg(c) ] -> - [ mytclWithHoles discr_tac true c ] -END - -let discrHyp id = - Proofview.tclEVARMAP >>= fun sigma -> - discr_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } - -let injection_main with_evars c = - elimOnConstrWithHoles (injClause None) with_evars c - -TACTIC EXTEND injection -| [ "injection" ] -> [ injClause None false None ] -| [ "injection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) false c ] -END -TACTIC EXTEND einjection -| [ "einjection" ] -> [ injClause None true None ] -| [ "einjection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) true c ] -END -TACTIC EXTEND injection_as -| [ "injection" "as" intropattern_list(ipat)] -> - [ injClause (Some ipat) false None ] -| [ "injection" destruction_arg(c) "as" intropattern_list(ipat)] -> - [ mytclWithHoles (injClause (Some ipat)) false c ] -END -TACTIC EXTEND einjection_as -| [ "einjection" "as" intropattern_list(ipat)] -> - [ injClause (Some ipat) true None ] -| [ "einjection" destruction_arg(c) "as" intropattern_list(ipat)] -> - [ mytclWithHoles (injClause (Some ipat)) true c ] -END -TACTIC EXTEND simple_injection -| [ "simple" "injection" ] -> [ simpleInjClause false None ] -| [ "simple" "injection" destruction_arg(c) ] -> [ mytclWithHoles simpleInjClause false c ] -END - -let injHyp id = - Proofview.tclEVARMAP >>= fun sigma -> - injection_main false { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } - -TACTIC EXTEND dependent_rewrite -| [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] -| [ "dependent" "rewrite" orient(b) constr(c) "in" hyp(id) ] - -> [ rewriteInHyp b c id ] -END - -(** To be deprecated?, "cutrewrite (t=u) as <-" is equivalent to - "replace u with t" or "enough (t=u) as <-" and - "cutrewrite (t=u) as ->" is equivalent to "enough (t=u) as ->". *) - -TACTIC EXTEND cut_rewrite -| [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ] -| [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] - -> [ cutRewriteInHyp b eqn id ] -END - -(**********************************************************************) -(* Decompose *) - -TACTIC EXTEND decompose_sum -| [ "decompose" "sum" constr(c) ] -> [ Elim.h_decompose_or c ] -END - -TACTIC EXTEND decompose_record -| [ "decompose" "record" constr(c) ] -> [ Elim.h_decompose_and c ] -END - -(**********************************************************************) -(* Contradiction *) - -open Contradiction - -TACTIC EXTEND absurd - [ "absurd" constr(c) ] -> [ absurd c ] -END - -let onSomeWithHoles tac = function - | None -> tac None - | Some c -> Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> tac (Some c)) - -TACTIC EXTEND contradiction - [ "contradiction" constr_with_bindings_opt(c) ] -> - [ onSomeWithHoles contradiction c ] -END - -(**********************************************************************) -(* AutoRewrite *) - -open Autorewrite - -let pr_orient _prc _prlc _prt = function - | true -> Pp.mt () - | false -> Pp.str " <-" - -let pr_orient_string _prc _prlc _prt (orient, s) = - pr_orient _prc _prlc _prt orient ++ Pp.spc () ++ Pp.str s - -ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_string -| [ orient(r) preident(i) ] -> [ r, i ] -END - -TACTIC EXTEND autorewrite -| [ "autorewrite" "with" ne_preident_list(l) clause(cl) ] -> - [ auto_multi_rewrite l ( cl) ] -| [ "autorewrite" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> - [ - auto_multi_rewrite_with (Tacinterp.tactic_of_value ist t) l cl - ] -END - -TACTIC EXTEND autorewrite_star -| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) ] -> - [ auto_multi_rewrite ~conds:AllMatches l cl ] -| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> - [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.tactic_of_value ist t) l cl ] -END - -(**********************************************************************) -(* Rewrite star *) - -let rewrite_star ist clause orient occs c (tac : Geninterp.Val.t option) = - let tac' = Option.map (fun t -> Tacinterp.tactic_of_value ist t, FirstSolved) tac in - with_delayed_uconstr ist c - (fun c -> general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) - -TACTIC EXTEND rewrite_star -| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> - [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star ist (Some id) o Locus.AllOccurrences c tac ] -| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> - [ rewrite_star ist None o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) uconstr(c) by_arg_tac(tac) ] -> - [ rewrite_star ist None o Locus.AllOccurrences c tac ] - END - -(**********************************************************************) -(* Hint Rewrite *) - -let add_rewrite_hint 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 c, ctx = Constrintern.interp_constr env sigma ce in - let ctx = - let ctx = UState.context_set ctx in - if poly then ctx - else (** This is a global universe context that shouldn't be - refreshed at every use of the hint, declare it globally. *) - (Declare.declare_universe_context false ctx; - Univ.ContextSet.empty) - in - Constrexpr_ops.constr_loc ce, (c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t in - let eqs = List.map f lcsr in - let add_hints base = add_rew_rules base eqs in - List.iter add_hints bases - -let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater - -VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY classify_hint - [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> - [ add_rewrite_hint bl o None l ] -| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) - ":" preident_list(bl) ] -> - [ add_rewrite_hint bl o (Some t) l ] -| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> - [ add_rewrite_hint ["core"] o None l ] -| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> - [ add_rewrite_hint ["core"] o (Some t) l ] -END - -(**********************************************************************) -(* Hint Resolve *) - -open Term -open Vars -open Coqlib - -let project_hint pri l2r r = - let gr = Smartlocate.global_with_alias r in - let env = Global.env() in - let sigma = Evd.from_env env in - let sigma, c = Evd.fresh_global env sigma gr in - let t = Retyping.get_type_of env sigma c in - let t = - Tacred.reduce_to_quantified_ref env sigma (Lazy.force coq_iff_ref) t in - let sign,ccl = decompose_prod_assum t in - let (a,b) = match snd (decompose_app ccl) with - | [a;b] -> (a,b) - | _ -> assert false in - let p = - if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in - let c = Reductionops.whd_beta Evd.empty (mkApp (c, Context.Rel.to_extended_vect 0 sign)) in - let c = it_mkLambda_or_LetIn - (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in - let id = - Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) - in - let ctx = Evd.universe_context_set sigma 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 l2r lc n bl = - let l = Locality.LocalityFixme.consume () in - Hints.add_hints (Locality.make_module_locality l) bl - (Hints.HintsResolveEntry (List.map (project_hint n l2r) lc)) - -VERNAC COMMAND EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF - [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) - ":" preident_list(bl) ] -> - [ add_hints_iff true lc n bl ] -| [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ] -> - [ add_hints_iff true lc n ["core"] ] -END -VERNAC COMMAND EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF - [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) - ":" preident_list(bl) ] -> - [ add_hints_iff false lc n bl ] -| [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ] -> - [ add_hints_iff false lc n ["core"] ] -END - -(**********************************************************************) -(* Refine *) - -let constr_flags = { - Pretyping.use_typeclasses = true; - Pretyping.solve_unification_constraints = true; - Pretyping.use_hook = Some Pfedit.solve_by_implicit_tactic; - Pretyping.fail_evar = false; - Pretyping.expand_evars = true } - -let refine_tac ist simple with_classes c = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let concl = Proofview.Goal.concl gl in - let env = Proofview.Goal.env gl in - let flags = - { constr_flags with Pretyping.use_typeclasses = with_classes } in - let expected_type = Pretyping.OfType concl in - let c = Pretyping.type_uconstr ~flags ~expected_type ist c in - let update = { run = fun sigma -> c.delayed env sigma } in - let refine = Refine.refine ~unsafe:true update in - if simple then refine - else refine <*> - Tactics.New.reduce_after_refine <*> - Proofview.shelve_unifiable - end } - -TACTIC EXTEND refine -| [ "refine" uconstr(c) ] -> - [ refine_tac ist false true c ] -END - -TACTIC EXTEND simple_refine -| [ "simple" "refine" uconstr(c) ] -> - [ refine_tac ist true true c ] -END - -TACTIC EXTEND notcs_refine -| [ "notypeclasses" "refine" uconstr(c) ] -> - [ refine_tac ist false false c ] -END - -TACTIC EXTEND notcs_simple_refine -| [ "simple" "notypeclasses" "refine" uconstr(c) ] -> - [ refine_tac ist true false c ] -END - -(* Solve unification constraints using heuristics or fail if any remain *) -TACTIC EXTEND solve_constraints -[ "solve_constraints" ] -> [ Refine.solve_constraints ] -END - -(**********************************************************************) -(* Inversion lemmas (Leminv) *) - -open Inv -open Leminv - -let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater - -VERNAC ARGUMENT EXTEND sort -| [ "Set" ] -> [ GSet ] -| [ "Prop" ] -> [ GProp ] -| [ "Type" ] -> [ GType [] ] -END - -VERNAC COMMAND EXTEND DeriveInversionClear -| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] - => [ seff na ] - -> [ add_inversion_lemma_exn na c s false inv_clear_tac ] - -| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ] - -> [ add_inversion_lemma_exn na c GProp false inv_clear_tac ] -END - -open Term - -VERNAC COMMAND EXTEND DeriveInversion -| [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] - => [ seff na ] - -> [ add_inversion_lemma_exn na c s false inv_tac ] - -| [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ] - -> [ add_inversion_lemma_exn na c GProp false inv_tac ] -END - -VERNAC COMMAND EXTEND DeriveDependentInversion -| [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] - => [ seff na ] - -> [ add_inversion_lemma_exn na c s true dinv_tac ] -END - -VERNAC COMMAND EXTEND DeriveDependentInversionClear -| [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] - => [ seff na ] - -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ] -END - -(**********************************************************************) -(* Subst *) - -TACTIC EXTEND subst -| [ "subst" ne_var_list(l) ] -> [ subst l ] -| [ "subst" ] -> [ subst_all () ] -END - -let simple_subst_tactic_flags = - { only_leibniz = true; rewrite_dependent_proof = false } - -TACTIC EXTEND simple_subst -| [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags () ] -END - -open Evar_tactics - -(**********************************************************************) -(* Evar creation *) - -(* TODO: add support for some test similar to g_constr.name_colon so that - expressions like "evar (list A)" do not raise a syntax error *) -TACTIC EXTEND evar - [ "evar" "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name id) typ ] -| [ "evar" constr(typ) ] -> [ let_evar Anonymous typ ] -END - -TACTIC EXTEND instantiate - [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] -> - [ Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals ] -| [ "instantiate" "(" integer(i) ":=" lglob(c) ")" hloc(hl) ] -> - [ Tacticals.New.tclTHEN (instantiate_tac i c hl) Proofview.V82.nf_evar_goals ] -| [ "instantiate" ] -> [ Proofview.V82.nf_evar_goals ] -END - -(**********************************************************************) -(** Nijmegen "step" tactic for setoid rewriting *) - -open Tactics -open Glob_term -open Libobject -open Lib - -(* Registered lemmas are expected to be of the form - x R y -> y == z -> x R z (in the right table) - x R y -> x == z -> z R y (in the left table) -*) - -let transitivity_right_table = Summary.ref [] ~name:"transitivity-steps-r" -let transitivity_left_table = Summary.ref [] ~name:"transitivity-steps-l" - -(* [step] tries to apply a rewriting lemma; then apply [tac] intended to - complete to proof of the last hypothesis (assumed to state an equality) *) - -let step left x tac = - let l = - List.map (fun lem -> - Tacticals.New.tclTHENLAST - (apply_with_bindings (lem, ImplicitBindings [x])) - tac) - !(if left then transitivity_left_table else transitivity_right_table) - in - Tacticals.New.tclFIRST l - -(* Main function to push lemmas in persistent environment *) - -let cache_transitivity_lemma (_,(left,lem)) = - if left then - transitivity_left_table := lem :: !transitivity_left_table - else - transitivity_right_table := lem :: !transitivity_right_table - -let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref) - -let inTransitivity : bool * constr -> obj = - declare_object {(default_object "TRANSITIVITY-STEPS") with - cache_function = cache_transitivity_lemma; - open_function = (fun i o -> if Int.equal i 1 then cache_transitivity_lemma o); - subst_function = subst_transitivity_lemma; - classify_function = (fun o -> Substitute o) } - -(* Main entry points *) - -let add_transitivity_lemma left lem = - let env = Global.env () in - let sigma = Evd.from_env env in - let lem',ctx (*FIXME*) = Constrintern.interp_constr env sigma lem in - add_anonymous_leaf (inTransitivity (left,lem')) - -(* Vernacular syntax *) - -TACTIC EXTEND stepl -| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.tactic_of_value ist tac) ] -| ["stepl" constr(c) ] -> [ step true c (Proofview.tclUNIT ()) ] -END - -TACTIC EXTEND stepr -| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.tactic_of_value ist tac) ] -| ["stepr" constr(c) ] -> [ step false c (Proofview.tclUNIT ()) ] -END - -VERNAC COMMAND EXTEND AddStepl CLASSIFIED AS SIDEFF -| [ "Declare" "Left" "Step" constr(t) ] -> - [ add_transitivity_lemma true t ] -END - -VERNAC COMMAND EXTEND AddStepr CLASSIFIED AS SIDEFF -| [ "Declare" "Right" "Step" constr(t) ] -> - [ add_transitivity_lemma false t ] -END - -let cache_implicit_tactic (_,tac) = match tac with - | Some tac -> Pfedit.declare_implicit_tactic (Tacinterp.eval_tactic tac) - | None -> Pfedit.clear_implicit_tactic () - -let subst_implicit_tactic (subst,tac) = - Option.map (Tacsubst.subst_tactic subst) tac - -let inImplicitTactic : glob_tactic_expr option -> obj = - declare_object {(default_object "IMPLICIT-TACTIC") with - open_function = (fun i o -> if Int.equal i 1 then cache_implicit_tactic o); - cache_function = cache_implicit_tactic; - subst_function = subst_implicit_tactic; - classify_function = (fun o -> Dispose)} - -let declare_implicit_tactic tac = - Lib.add_anonymous_leaf (inImplicitTactic (Some (Tacintern.glob_tactic tac))) - -let clear_implicit_tactic () = - Lib.add_anonymous_leaf (inImplicitTactic None) - -VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF -| [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> [ declare_implicit_tactic tac ] -| [ "Clear" "Implicit" "Tactic" ] -> [ clear_implicit_tactic () ] -END - - - - -(**********************************************************************) -(*spiwack : Vernac commands for retroknowledge *) - -VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF - | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> - [ let tc,ctx = Constrintern.interp_constr (Global.env ()) Evd.empty c in - let tb,ctx(*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty b in - Global.register f tc tb ] -END - - - -(**********************************************************************) -(* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as - defined by Conor McBride *) -TACTIC EXTEND generalize_eqs -| ["generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false id ] -END -TACTIC EXTEND dep_generalize_eqs -| ["dependent" "generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false ~force_dep:true id ] -END -TACTIC EXTEND generalize_eqs_vars -| ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~generalize_vars:true id ] -END -TACTIC EXTEND dep_generalize_eqs_vars -| ["dependent" "generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~force_dep:true ~generalize_vars:true id ] -END - -(** Tactic to automatically simplify hypotheses of the form [Π Δ, x_i = t_i -> T] - where [t_i] is closed w.r.t. Δ. Such hypotheses are automatically generated - during dependent induction. For internal use. *) - -TACTIC EXTEND specialize_eqs -[ "specialize_eqs" hyp(id) ] -> [ specialize_eqs id ] -END - -(**********************************************************************) -(* A tactic that considers a given occurrence of [c] in [t] and *) -(* abstract the minimal set of all the occurrences of [c] so that the *) -(* abstraction [fun x -> t[x/c]] is well-typed *) -(* *) -(* Contributed by Chung-Kil Hur (Winter 2009) *) -(**********************************************************************) - -let subst_var_with_hole occ tid t = - let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in - let locref = ref 0 in - let rec substrec = function - | GVar (_,id) as x -> - if Id.equal id tid - then - (decr occref; - if Int.equal !occref 0 then x - else - (incr locref; - GHole (Loc.make_loc (!locref,0), - Evar_kinds.QuestionMark(Evar_kinds.Define true), - Misctypes.IntroAnonymous, None))) - else x - | c -> map_glob_constr_left_to_right substrec c in - let t' = substrec t - in - if !occref > 0 then Find_subterm.error_invalid_occurrence [occ] else t' - -let subst_hole_with_term occ tc t = - let locref = ref 0 in - let occref = ref occ in - let rec substrec = function - | GHole (_,Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s) -> - decr occref; - if Int.equal !occref 0 then tc - else - (incr locref; - GHole (Loc.make_loc (!locref,0), - Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s)) - | c -> map_glob_constr_left_to_right substrec c - in - substrec t - -open Tacmach - -let hResolve id c occ t = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in - let sigma = Sigma.to_evar_map sigma in - let env = Termops.clear_named_body id (Proofview.Goal.env gl) in - let concl = Proofview.Goal.concl gl in - let env_ids = Termops.ids_of_context env in - let c_raw = Detyping.detype true env_ids env sigma c in - let t_raw = Detyping.detype true env_ids env sigma t in - let rec resolve_hole t_hole = - try - Pretyping.understand env sigma t_hole - with - | Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _) as e -> - let (e, info) = CErrors.push e in - let loc = match Loc.get_loc info with None -> Loc.ghost | Some loc -> loc in - resolve_hole (subst_hole_with_term (fst (Loc.unloc loc)) c_raw t_hole) - in - let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in - let sigma = Evd.merge_universe_context sigma ctx in - let t_constr_type = Retyping.get_type_of env sigma t_constr in - let tac = - (change_concl (mkLetIn (Anonymous,t_constr,t_constr_type,concl))) - in - Sigma.Unsafe.of_pair (tac, sigma) - end } - -let hResolve_auto id c t = - let rec resolve_auto n = - try - hResolve id c n t - with - | UserError _ as e -> raise e - | e when CErrors.noncritical e -> resolve_auto (n+1) - in - resolve_auto 1 - -TACTIC EXTEND hresolve_core -| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c occ t ] -| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> [ hResolve_auto id c t ] -END - -(** - hget_evar -*) - -let hget_evar n = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let sigma = Tacmach.New.project gl in - let concl = Proofview.Goal.concl gl in - let evl = evar_list concl in - if List.length evl < n then - error "Not enough uninstantiated existential variables."; - if n <= 0 then error "Incorrect existential variable index."; - let ev = List.nth evl (n-1) in - let ev_type = existential_type sigma ev in - change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl)) - end } - -TACTIC EXTEND hget_evar -| [ "hget_evar" int_or_var(n) ] -> [ hget_evar n ] -END - -(**********************************************************************) - -(**********************************************************************) -(* A tactic that reduces one match t with ... by doing destruct t. *) -(* if t is not a variable, the tactic does *) -(* case_eq t;intros ... heq;rewrite heq in *|-. (but heq itself is *) -(* preserved). *) -(* Contributed by Julien Forest and Pierre Courtieu (july 2010) *) -(**********************************************************************) - -exception Found of unit Proofview.tactic - -let rewrite_except h = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let hyps = Tacmach.New.pf_ids_of_hyps gl in - Tacticals.New.tclMAP (fun id -> if Id.equal id h then Proofview.tclUNIT () else - Tacticals.New.tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true true id (mkVar h) false)) - hyps - end } - - -let refl_equal = - let coq_base_constant s = - Coqlib.gen_constant_in_modules "RecursiveDefinition" - (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s in - function () -> (coq_base_constant "eq_refl") - - -(* This is simply an implementation of the case_eq tactic. this code - should be replaced by a call to the tactic but I don't know how to - call it before it is defined. *) -let mkCaseEq a : unit Proofview.tactic = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let type_of_a = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g a) gl in - Tacticals.New.tclTHENLIST - [Tactics.generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]; - Proofview.Goal.nf_enter { enter = begin fun gl -> - let concl = Proofview.Goal.concl gl in - let env = Proofview.Goal.env gl in - (** FIXME: this looks really wrong. Does anybody really use this tactic? *) - let Sigma (c, _, _) = (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a]).Reductionops.e_redfun env (Sigma.Unsafe.of_evar_map Evd.empty) concl in - change_concl c - end }; - simplest_case a] - end } - - -let case_eq_intros_rewrite x = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let n = nb_prod (Proofview.Goal.concl gl) in - (* Pp.msgnl (Printer.pr_lconstr x); *) - Tacticals.New.tclTHENLIST [ - mkCaseEq x; - Proofview.Goal.nf_enter { enter = begin fun gl -> - let concl = Proofview.Goal.concl gl in - let hyps = Tacmach.New.pf_ids_of_hyps gl in - let n' = nb_prod concl in - let h = Tacmach.New.of_old (fun g -> fresh_id hyps (Id.of_string "heq") g) gl in - Tacticals.New.tclTHENLIST [ - Tacticals.New.tclDO (n'-n-1) intro; - introduction h; - rewrite_except h] - end } - ] - end } - -let rec find_a_destructable_match t = - let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in - let cl = [cl, (None, None), None], None in - let dest = TacAtom (Loc.ghost, TacInductionDestruct(false, false, cl)) in - match kind_of_term t with - | Case (_,_,x,_) when closed0 x -> - if isVar x then - (* TODO check there is no rel n. *) - raise (Found (Tacinterp.eval_tactic dest)) - else - (* let _ = Pp.msgnl (Printer.pr_lconstr x) in *) - raise (Found (case_eq_intros_rewrite x)) - | _ -> iter_constr find_a_destructable_match t - - -let destauto t = - try find_a_destructable_match t; - Tacticals.New.tclZEROMSG (str "No destructable match found") - with Found tac -> tac - -let destauto_in id = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let ctype = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g (mkVar id)) gl in -(* Pp.msgnl (Printer.pr_lconstr (mkVar id)); *) -(* Pp.msgnl (Printer.pr_lconstr (ctype)); *) - destauto ctype - end } - -TACTIC EXTEND destauto -| [ "destauto" ] -> [ Proofview.Goal.nf_enter { enter = begin fun gl -> destauto (Proofview.Goal.concl gl) end } ] -| [ "destauto" "in" hyp(id) ] -> [ destauto_in id ] -END - - -(* ********************************************************************* *) - -let eq_constr x y = - Proofview.Goal.enter { enter = begin fun gl -> - let evd = Tacmach.New.project gl in - if Evarutil.eq_constr_univs_test evd evd x y then Proofview.tclUNIT () - else Tacticals.New.tclFAIL 0 (str "Not equal") - end } - -TACTIC EXTEND constr_eq -| [ "constr_eq" constr(x) constr(y) ] -> [ eq_constr x y ] -END - -TACTIC EXTEND constr_eq_nounivs -| [ "constr_eq_nounivs" constr(x) constr(y) ] -> [ - if eq_constr_nounivs x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ] -END - -TACTIC EXTEND is_evar -| [ "is_evar" constr(x) ] -> - [ Proofview.tclBIND Proofview.tclEVARMAP begin fun sigma -> - match Evarutil.kind_of_term_upto sigma x with - | Evar _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (str "Not an evar") - end - ] -END - -let rec has_evar x = - match kind_of_term x with - | Evar _ -> true - | Rel _ | Var _ | Meta _ | Sort _ | Const _ | Ind _ | Construct _ -> - false - | Cast (t1, _, t2) | Prod (_, t1, t2) | Lambda (_, t1, t2) -> - has_evar t1 || has_evar t2 - | LetIn (_, t1, t2, t3) -> - has_evar t1 || has_evar t2 || has_evar t3 - | App (t1, ts) -> - has_evar t1 || has_evar_array ts - | Case (_, t1, t2, ts) -> - has_evar t1 || has_evar t2 || has_evar_array ts - | Fix ((_, tr)) | CoFix ((_, tr)) -> - has_evar_prec tr - | Proj (p, c) -> has_evar c -and has_evar_array x = - Array.exists has_evar x -and has_evar_prec (_, ts1, ts2) = - Array.exists has_evar ts1 || Array.exists has_evar ts2 - -TACTIC EXTEND has_evar -| [ "has_evar" constr(x) ] -> - [ if has_evar x then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "No evars") ] -END - -TACTIC EXTEND is_hyp -| [ "is_var" constr(x) ] -> - [ match kind_of_term x with - | Var _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (str "Not a variable or hypothesis") ] -END - -TACTIC EXTEND is_fix -| [ "is_fix" constr(x) ] -> - [ match kind_of_term x with - | Fix _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a fix definition") ] -END;; - -TACTIC EXTEND is_cofix -| [ "is_cofix" constr(x) ] -> - [ match kind_of_term x with - | CoFix _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") ] -END;; - -TACTIC EXTEND is_ind -| [ "is_ind" constr(x) ] -> - [ match kind_of_term x with - | Ind _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not an (co)inductive datatype") ] -END;; - -TACTIC EXTEND is_constructor -| [ "is_constructor" constr(x) ] -> - [ match kind_of_term x with - | Construct _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constructor") ] -END;; - -TACTIC EXTEND is_proj -| [ "is_proj" constr(x) ] -> - [ match kind_of_term x with - | Proj _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a primitive projection") ] -END;; - -TACTIC EXTEND is_const -| [ "is_const" constr(x) ] -> - [ match kind_of_term x with - | Const _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constant") ] -END;; - -(* Command to grab the evars left unresolved at the end of a proof. *) -(* spiwack: I put it in extratactics because it is somewhat tied with - the semantics of the LCF-style tactics, hence with the classic tactic - mode. *) -VERNAC COMMAND EXTEND GrabEvars -[ "Grab" "Existential" "Variables" ] - => [ Vernac_classifier.classify_as_proofstep ] - -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) ] -END - -(* Shelves all the goals under focus. *) -TACTIC EXTEND shelve -| [ "shelve" ] -> - [ Proofview.shelve ] -END - -(* Shelves the unifiable goals under focus, i.e. the goals which - appear in other goals under focus (the unfocused goals are not - considered). *) -TACTIC EXTEND shelve_unifiable -| [ "shelve_unifiable" ] -> - [ Proofview.shelve_unifiable ] -END - -(* Unshelves the goal shelved by the tactic. *) -TACTIC EXTEND unshelve -| [ "unshelve" tactic1(t) ] -> - [ - Proofview.with_shelf (Tacinterp.tactic_of_value ist t) >>= fun (gls, ()) -> - Proofview.Unsafe.tclGETGOALS >>= fun ogls -> - Proofview.Unsafe.tclSETGOALS (gls @ ogls) - ] -END - -(* Command to add every unshelved variables to the focus *) -VERNAC COMMAND EXTEND Unshelve -[ "Unshelve" ] - => [ Vernac_classifier.classify_as_proofstep ] - -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) ] -END - -(* Gives up on the goals under focus: the goals are considered solved, - but the proof cannot be closed until the user goes back and solve - these goals. *) -TACTIC EXTEND give_up -| [ "give_up" ] -> - [ Proofview.give_up ] -END - -(* cycles [n] goals *) -TACTIC EXTEND cycle -| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle n ] -END - -(* swaps goals number [i] and [j] *) -TACTIC EXTEND swap -| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap i j ] -END - -(* reverses the list of focused goals *) -TACTIC EXTEND revgoals -| [ "revgoals" ] -> [ Proofview.revgoals ] -END - -type cmp = - | Eq - | Lt | Le - | Gt | Ge - -type 'i test = - | Test of cmp * 'i * 'i - -let pr_cmp = function - | Eq -> Pp.str"=" - | Lt -> Pp.str"<" - | Le -> Pp.str"<=" - | Gt -> Pp.str">" - | Ge -> Pp.str">=" - -let pr_cmp' _prc _prlc _prt = pr_cmp - -let pr_test_gen f (Test(c,x,y)) = - Pp.(f x ++ pr_cmp c ++ f y) - -let pr_test = pr_test_gen (Pputils.pr_or_var Pp.int) - -let pr_test' _prc _prlc _prt = pr_test - -let pr_itest = pr_test_gen Pp.int - -let pr_itest' _prc _prlc _prt = pr_itest - - - -ARGUMENT EXTEND comparison PRINTED BY pr_cmp' -| [ "=" ] -> [ Eq ] -| [ "<" ] -> [ Lt ] -| [ "<=" ] -> [ Le ] -| [ ">" ] -> [ Gt ] -| [ ">=" ] -> [ Ge ] - END - -let interp_test ist gls = function - | Test (c,x,y) -> - project gls , - Test(c,Tacinterp.interp_int_or_var ist x,Tacinterp.interp_int_or_var ist y) - -ARGUMENT EXTEND test - PRINTED BY pr_itest' - INTERPRETED BY interp_test - RAW_PRINTED BY pr_test' - GLOB_PRINTED BY pr_test' -| [ int_or_var(x) comparison(c) int_or_var(y) ] -> [ Test(c,x,y) ] -END - -let interp_cmp = function - | Eq -> Int.equal - | Lt -> ((<):int->int->bool) - | Le -> ((<=):int->int->bool) - | Gt -> ((>):int->int->bool) - | Ge -> ((>=):int->int->bool) - -let run_test = function - | Test(c,x,y) -> interp_cmp c x y - -let guard tst = - if run_test tst then - Proofview.tclUNIT () - else - let msg = Pp.(str"Condition not satisfied:"++ws 1++(pr_itest tst)) in - Tacticals.New.tclZEROMSG msg - - -TACTIC EXTEND guard -| [ "guard" test(tst) ] -> [ guard tst ] -END - -let decompose l c = - Proofview.Goal.enter { enter = begin fun gl -> - let to_ind c = - if isInd c then Univ.out_punivs (destInd c) - else error "not an inductive type" - in - let l = List.map to_ind l in - Elim.h_decompose l c - end } - -TACTIC EXTEND decompose -| [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ] -END - -(** library/keys *) - -VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF -| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> [ - let it c = snd (Constrintern.interp_open_constr (Global.env ()) Evd.empty c) in - let k1 = Keys.constr_key (it c) in - let k2 = Keys.constr_key (it c') in - match k1, k2 with - | Some k1, Some k2 -> Keys.declare_equiv_keys k1 k2 - | _ -> () ] -END - -VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY -| [ "Print" "Equivalent" "Keys" ] -> [ Feedback.msg_info (Keys.pr_keys Printer.pr_global) ] -END - - -VERNAC COMMAND EXTEND OptimizeProof -| [ "Optimize" "Proof" ] => [ Vernac_classifier.classify_as_proofstep ] -> - [ Proof_global.compact_the_proof () ] -| [ "Optimize" "Heap" ] => [ Vernac_classifier.classify_as_proofstep ] -> - [ Gc.compact () ] -END diff --git a/ltac/extratactics.mli b/ltac/extratactics.mli deleted file mode 100644 index 18334dafe..000000000 --- a/ltac/extratactics.mli +++ /dev/null @@ -1,14 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit Proofview.tactic -val injHyp : Names.Id.t -> unit Proofview.tactic - -(* val refine_tac : Evd.open_constr -> unit Proofview.tactic *) - -val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Tacexpr.delayed_open option -> unit Proofview.tactic diff --git a/ltac/g_auto.ml4 b/ltac/g_auto.ml4 deleted file mode 100644 index a37cf306e..000000000 --- a/ltac/g_auto.ml4 +++ /dev/null @@ -1,228 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ Eauto.e_assumption ] -END - -TACTIC EXTEND eexact -| [ "eexact" constr(c) ] -> [ Eauto.e_give_exact c ] -END - -let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases - -ARGUMENT EXTEND hintbases - TYPED AS preident_list_opt - PRINTED BY pr_hintbases -| [ "with" "*" ] -> [ None ] -| [ "with" ne_preident_list(l) ] -> [ Some l ] -| [ ] -> [ Some [] ] -END - -let eval_uconstrs ist cs = - let flags = { - Pretyping.use_typeclasses = false; - solve_unification_constraints = true; - use_hook = Some Pfedit.solve_by_implicit_tactic; - fail_evar = false; - expand_evars = true - } in - List.map (fun c -> Pretyping.type_uconstr ~flags ist c) cs - -let pr_auto_using_raw _ _ _ = Pptactic.pr_auto_using Ppconstr.pr_constr_expr -let pr_auto_using_glob _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> Printer.pr_glob_constr c) -let pr_auto_using _ _ _ = Pptactic.pr_auto_using Printer.pr_closed_glob - -ARGUMENT EXTEND auto_using - TYPED AS uconstr_list - PRINTED BY pr_auto_using - RAW_TYPED AS uconstr_list - RAW_PRINTED BY pr_auto_using_raw - GLOB_TYPED AS uconstr_list - GLOB_PRINTED BY pr_auto_using_glob -| [ "using" ne_uconstr_list_sep(l, ",") ] -> [ l ] -| [ ] -> [ [] ] -END - -(** Auto *) - -TACTIC EXTEND trivial -| [ "trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND info_trivial -| [ "info_trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND debug_trivial -| [ "debug" "trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND auto -| [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto n (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND info_auto -| [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND debug_auto -| [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db ] -END - -(** Eauto *) - -TACTIC EXTEND prolog -| [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] -> - [ Eauto.prolog_tac (eval_uconstrs ist l) n ] -END - -let make_depth n = snd (Eauto.make_dimension n None) - -TACTIC EXTEND eauto -| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) - hintbases(db) ] -> - [ Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND new_eauto -| [ "new" "auto" int_or_var_opt(n) auto_using(lems) - hintbases(db) ] -> - [ match db with - | None -> Auto.new_full_auto (make_depth n) (eval_uconstrs ist lems) - | Some l -> Auto.new_auto (make_depth n) (eval_uconstrs ist lems) l ] -END - -TACTIC EXTEND debug_eauto -| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) - hintbases(db) ] -> - [ Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND info_eauto -| [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) - hintbases(db) ] -> - [ Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND dfs_eauto -| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) - hintbases(db) ] -> - [ Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND autounfold -| [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> [ Eauto.autounfold_tac db cl ] -END - -TACTIC EXTEND autounfold_one -| [ "autounfold_one" hintbases(db) "in" hyp(id) ] -> - [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, Locus.InHyp)) ] -| [ "autounfold_one" hintbases(db) ] -> - [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ] - END - -TACTIC EXTEND autounfoldify -| [ "autounfoldify" constr(x) ] -> [ - let db = match Term.kind_of_term x with - | Term.Const (c,_) -> Names.Label.to_string (Names.con_label c) - | _ -> assert false - in Eauto.autounfold ["core";db] Locusops.onConcl - ] -END - -TACTIC EXTEND unify -| ["unify" constr(x) constr(y) ] -> [ Tactics.unify x y ] -| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ - let table = try Some (Hints.searchtable_map base) with Not_found -> None in - match table with - | None -> - let msg = str "Hint table " ++ str base ++ str " not found" in - Tacticals.New.tclZEROMSG msg - | Some t -> - let state = Hints.Hint_db.transparent_state t in - Tactics.unify ~state x y - ] -END - - -TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x Term.DEFAULTcast ] -END - -let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_reference -let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global -let glob_hints_path_atom ist = Hints.glob_hints_path_atom - -ARGUMENT EXTEND hints_path_atom - PRINTED BY pr_hints_path_atom - - GLOBALIZED BY glob_hints_path_atom - - RAW_PRINTED BY pr_pre_hints_path_atom - GLOB_PRINTED BY pr_hints_path_atom -| [ ne_global_list(g) ] -> [ Hints.PathHints g ] -| [ "_" ] -> [ Hints.PathAny ] -END - -let pr_hints_path prc prx pry c = Hints.pp_hints_path c -let pr_pre_hints_path prc prx pry c = Hints.pp_hints_path_gen Libnames.pr_reference c -let glob_hints_path ist = Hints.glob_hints_path - -ARGUMENT EXTEND hints_path -PRINTED BY pr_hints_path - -GLOBALIZED BY glob_hints_path -RAW_PRINTED BY pr_pre_hints_path -GLOB_PRINTED BY pr_hints_path - -| [ "(" hints_path(p) ")" ] -> [ p ] -| [ hints_path(p) "*" ] -> [ Hints.PathStar p ] -| [ "emp" ] -> [ Hints.PathEmpty ] -| [ "eps" ] -> [ Hints.PathEpsilon ] -| [ hints_path(p) "|" hints_path(q) ] -> [ Hints.PathOr (p, q) ] -| [ hints_path_atom(a) ] -> [ Hints.PathAtom a ] -| [ hints_path(p) hints_path(q) ] -> [ Hints.PathSeq (p, q) ] -END - -ARGUMENT EXTEND opthints - TYPED AS preident_list_opt - PRINTED BY pr_hintbases -| [ ":" ne_preident_list(l) ] -> [ Some l ] -| [ ] -> [ None ] -END - -VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF -| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ - let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in - Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ())) - (match dbnames with None -> ["core"] | Some l -> l) entry ] -END - diff --git a/ltac/g_class.ml4 b/ltac/g_class.ml4 deleted file mode 100644 index a28132a4b..000000000 --- a/ltac/g_class.ml4 +++ /dev/null @@ -1,120 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let gr = Smartlocate.global_with_alias r in - let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in - Classes.set_typeclass_transparency ev false b) cl - -VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings CLASSIFIED AS SIDEFF -| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ - set_transparency cl true ] -END - -VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings CLASSIFIED AS SIDEFF -| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [ - set_transparency cl false ] -END - -open Genarg - -let pr_debug _prc _prlc _prt b = - if b then Pp.str "debug" else Pp.mt() - -ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug -| [ "debug" ] -> [ true ] -| [ ] -> [ false ] -END - -let pr_search_strategy _prc _prlc _prt = function - | Some Dfs -> Pp.str "dfs" - | Some Bfs -> Pp.str "bfs" - | None -> Pp.mt () - -ARGUMENT EXTEND eauto_search_strategy PRINTED BY pr_search_strategy -| [ "(bfs)" ] -> [ Some Bfs ] -| [ "(dfs)" ] -> [ Some Dfs ] -| [ ] -> [ None ] -END - -(* true = All transparent, false = Opaque if possible *) - -VERNAC COMMAND EXTEND Typeclasses_Settings CLASSIFIED AS SIDEFF - | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) int_opt(depth) ] -> [ - set_typeclasses_debug d; - Option.iter set_typeclasses_strategy s; - set_typeclasses_depth depth - ] -END - -(** Compatibility: typeclasses eauto has 8.5 and 8.6 modes *) -TACTIC EXTEND typeclasses_eauto - | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) "with" ne_preident_list(l) ] -> - [ typeclasses_eauto ~strategy:Bfs ~depth:d l ] - | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] -> - [ typeclasses_eauto ~depth:d l ] - | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> [ - typeclasses_eauto ~only_classes:true ~depth:d [Hints.typeclasses_db] ] -END - -TACTIC EXTEND head_of_constr - [ "head_of_constr" ident(h) constr(c) ] -> [ head_of_constr h c ] -END - -TACTIC EXTEND not_evar - [ "not_evar" constr(ty) ] -> [ not_evar ty ] -END - -TACTIC EXTEND is_ground - [ "is_ground" constr(ty) ] -> [ Proofview.V82.tactic (is_ground ty) ] -END - -TACTIC EXTEND autoapply - [ "autoapply" constr(c) "using" preident(i) ] -> [ Proofview.V82.tactic (autoapply c i) ] -END - -(** TODO: DEPRECATE *) -(* A progress test that allows to see if the evars have changed *) -open Term -open Proofview.Goal -open Proofview.Notations - -let rec eq_constr_mod_evars x y = - match kind_of_term x, kind_of_term y with - | Evar (e1, l1), Evar (e2, l2) when not (Evar.equal e1 e2) -> true - | _, _ -> compare_constr eq_constr_mod_evars x y - -let progress_evars t = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let concl = Proofview.Goal.concl gl in - let check = - Proofview.Goal.nf_enter { enter = begin fun gl' -> - let newconcl = Proofview.Goal.concl gl' in - if eq_constr_mod_evars concl newconcl - then Tacticals.New.tclFAIL 0 (Pp.str"No progress made (modulo evars)") - else Proofview.tclUNIT () - end } - in t <*> check - end } - -TACTIC EXTEND progress_evars - [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.tactic_of_value ist t) ] -END diff --git a/ltac/g_eqdecide.ml4 b/ltac/g_eqdecide.ml4 deleted file mode 100644 index 905653281..000000000 --- a/ltac/g_eqdecide.ml4 +++ /dev/null @@ -1,27 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ decideEqualityGoal ] -END - -TACTIC EXTEND compare -| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ] -END diff --git a/ltac/g_ltac.ml4 b/ltac/g_ltac.ml4 deleted file mode 100644 index 54229bb2a..000000000 --- a/ltac/g_ltac.ml4 +++ /dev/null @@ -1,526 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* a - | e -> Tacexp (e:raw_tactic_expr) - -let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () -let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n -let genarg_of_ipattern pat = in_gen (rawwit Stdarg.wit_intro_pattern) pat -let genarg_of_uconstr c = in_gen (rawwit Stdarg.wit_uconstr) c -let in_tac tac = in_gen (rawwit Tacarg.wit_ltac) tac - -let reference_to_id = function - | Libnames.Ident (loc, id) -> (loc, id) - | Libnames.Qualid (loc,_) -> - CErrors.user_err ~loc - (str "This expression should be a simple identifier.") - -let tactic_mode = Gram.entry_create "vernac:tactic_command" - -let new_entry name = - let e = Gram.entry_create name in - e - -let toplevel_selector = new_entry "vernac:toplevel_selector" -let tacdef_body = new_entry "tactic:tacdef_body" - -(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for - proof editing and changes nothing else). Then sets it as the default proof mode. *) -let _ = - let mode = { - Proof_global.name = "Classic"; - set = (fun () -> set_command_entry tactic_mode); - reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); - } in - Proof_global.register_proof_mode mode - -(* Hack to parse "[ id" without dropping [ *) -let test_bracket_ident = - Gram.Entry.of_parser "test_bracket_ident" - (fun strm -> - match get_tok (stream_nth 0 strm) with - | KEYWORD "[" -> - (match get_tok (stream_nth 1 strm) with - | IDENT _ -> () - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - -(* Tactics grammar rules *) - -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 - operconstr; - - tactic_then_last: - [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> - Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) - | -> [||] - ] ] - ; - tactic_then_gen: - [ [ ta = tactic_expr; "|"; (first,last) = tactic_then_gen -> (ta::first, last) - | ta = tactic_expr; ".."; l = tactic_then_last -> ([], Some (ta, l)) - | ".."; l = tactic_then_last -> ([], Some (TacId [], l)) - | ta = tactic_expr -> ([ta], None) - | "|"; (first,last) = tactic_then_gen -> (TacId [] :: first, last) - | -> ([TacId []], None) - ] ] - ; - tactic_then_locality: (* [true] for the local variant [TacThens] and [false] - for [TacExtend] *) - [ [ "[" ; l = OPT">" -> if Option.is_empty l then true else false ] ] - ; - tactic_expr: - [ "5" RIGHTA - [ te = binder_tactic -> te ] - | "4" LEFTA - [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, ta1) - | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0,ta1) - | ta0 = tactic_expr; ";"; l = tactic_then_locality; (first,tail) = tactic_then_gen; "]" -> - match l , tail with - | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) - | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) - | false , None -> TacThen (ta0,TacDispatch first) - | true , None -> TacThens (ta0,first) ] - | "3" RIGHTA - [ IDENT "try"; ta = tactic_expr -> TacTry ta - | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta) - | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> TacTimeout (n,ta) - | IDENT "time"; s = OPT string; ta = tactic_expr -> TacTime (s,ta) - | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta - | IDENT "progress"; ta = tactic_expr -> TacProgress ta - | IDENT "once"; ta = tactic_expr -> TacOnce ta - | IDENT "exactly_once"; ta = tactic_expr -> TacExactlyOnce ta - | IDENT "infoH"; ta = tactic_expr -> TacShowHyps ta -(*To do: put Abstract in Refiner*) - | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) - | IDENT "abstract"; tc = NEXT; "using"; s = ident -> - TacAbstract (tc,Some s) - | sel = selector; ta = tactic_expr -> TacSelect (sel, ta) ] -(*End of To do*) - | "2" RIGHTA - [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> TacOr (ta0,ta1) - | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> TacOr (ta0,ta1) - | IDENT "tryif" ; ta = tactic_expr ; - "then" ; tat = tactic_expr ; - "else" ; tae = tactic_expr -> TacIfThenCatch(ta,tat,tae) - | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1) - | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ] - | "1" RIGHTA - [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> - TacMatchGoal (b,false,mrl) - | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; - mrl = match_context_list; "end" -> - TacMatchGoal (b,true,mrl) - | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> - TacMatch (b,c,mrl) - | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacFirst l - | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacSolve l - | IDENT "idtac"; l = LIST0 message_token -> TacId l - | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; - l = LIST0 message_token -> TacFail (g,n,l) - | st = simple_tactic -> st - | a = tactic_arg -> TacArg(!@loc,a) - | r = reference; la = LIST0 tactic_arg_compat -> - TacArg(!@loc,TacCall (!@loc,r,la)) ] - | "0" - [ "("; a = tactic_expr; ")" -> a - | "["; ">"; (tf,tail) = tactic_then_gen; "]" -> - begin match tail with - | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) - | None -> TacDispatch tf - end - | a = tactic_atom -> TacArg (!@loc,a) ] ] - ; - failkw: - [ [ IDENT "fail" -> TacLocal | IDENT "gfail" -> TacGlobal ] ] - ; - (* binder_tactic: level 5 of tactic_expr *) - binder_tactic: - [ RIGHTA - [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> - TacFun (it,body) - | "let"; isrec = [IDENT "rec" -> true | -> false]; - llc = LIST1 let_clause SEP "with"; "in"; - body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body) - | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] - ; - (* Tactic arguments to the right of an application *) - tactic_arg_compat: - [ [ a = tactic_arg -> a - | c = Constr.constr -> (match c with CRef (r,None) -> Reference r | c -> ConstrMayEval (ConstrTerm c)) - (* Unambiguous entries: tolerated w/o "ltac:" modifier *) - | "()" -> TacGeneric (genarg_of_unit ()) ] ] - ; - (* Can be used as argument and at toplevel in tactic expressions. *) - tactic_arg: - [ [ c = constr_eval -> ConstrMayEval c - | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l - | IDENT "type_term"; c=uconstr -> TacPretype c - | IDENT "numgoals" -> TacNumgoals ] ] - ; - (* If a qualid is given, use its short name. TODO: have the shortest - non ambiguous name where dots are replaced by "_"? Probably too - verbose most of the time. *) - fresh_id: - [ [ s = STRING -> ArgArg s (*| id = ident -> ArgVar (!@loc,id)*) - | qid = qualid -> let (_pth,id) = Libnames.repr_qualid (snd qid) in ArgVar (!@loc,id) ] ] - ; - constr_eval: - [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> - ConstrEval (rtc,c) - | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> - ConstrContext (id,c) - | IDENT "type"; IDENT "of"; c = Constr.constr -> - ConstrTypeOf c ] ] - ; - constr_may_eval: (* For extensions *) - [ [ c = constr_eval -> c - | c = Constr.constr -> ConstrTerm c ] ] - ; - tactic_atom: - [ [ n = integer -> TacGeneric (genarg_of_int n) - | r = reference -> TacCall (!@loc,r,[]) - | "()" -> TacGeneric (genarg_of_unit ()) ] ] - ; - match_key: - [ [ "match" -> Once - | "lazymatch" -> Select - | "multimatch" -> General ] ] - ; - input_fun: - [ [ "_" -> None - | l = ident -> Some l ] ] - ; - let_clause: - [ [ id = identref; ":="; te = tactic_expr -> - (id, arg_of_expr te) - | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> - (id, arg_of_expr (TacFun(args,te))) ] ] - ; - 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) - | pc = Constr.lconstr_pattern -> Term pc ] ] - ; - match_hyps: - [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) - | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt) - | na = name; ":="; mpv = match_pattern -> - let t, ty = - match mpv with - | Term t -> (match t with - | CCast (loc, t, (CastConv ty | CastVM ty | CastNative ty)) -> Term t, Some (Term ty) - | _ -> mpv, None) - | _ -> mpv, None - in Def (na, t, Option.default (Term (CHole (Loc.ghost, None, IntroAnonymous, None))) ty) - ] ] - ; - match_context_rule: - [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "=>"; te = tactic_expr -> Pat (largs, mp, te) - | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te) - | "_"; "=>"; te = tactic_expr -> All te ] ] - ; - match_context_list: - [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl - | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ] - ; - match_rule: - [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te) - | "_"; "=>"; te = tactic_expr -> All te ] ] - ; - match_list: - [ [ mrl = LIST1 match_rule SEP "|" -> mrl - | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] - ; - message_token: - [ [ id = identref -> MsgIdent id - | s = STRING -> MsgString s - | n = integer -> MsgInt n ] ] - ; - - ltac_def_kind: - [ [ ":=" -> false - | "::=" -> true ] ] - ; - - (* Definitions for tactics *) - tacdef_body: - [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> - if redef then Tacexpr.TacticRedefinition (name, TacFun (it, body)) - else - let id = reference_to_id name in - Tacexpr.TacticDefinition (id, TacFun (it, body)) - | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> - if redef then Tacexpr.TacticRedefinition (name, body) - else - let id = reference_to_id name in - Tacexpr.TacticDefinition (id, body) - ] ] - ; - tactic: - [ [ tac = tactic_expr -> tac ] ] - ; - - range_selector: - [ [ n = natural ; "-" ; m = natural -> (n, m) - | n = natural -> (n, n) ] ] - ; - (* We unfold a range selectors list once so that we can make a special case - * for a unique SelectNth selector. *) - range_selector_or_nth: - [ [ n = natural ; "-" ; m = natural; - l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> - SelectList ((n, m) :: Option.default [] l) - | n = natural; - l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> - Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l ] ] - ; - selector_body: - [ [ l = range_selector_or_nth -> l - | test_bracket_ident; "["; id = ident; "]" -> SelectId id ] ] - ; - selector: - [ [ IDENT "only"; sel = selector_body; ":" -> sel ] ] - ; - toplevel_selector: - [ [ sel = selector_body; ":" -> sel - | IDENT "all"; ":" -> SelectAll ] ] - ; - tactic_mode: - [ [ g = OPT toplevel_selector; tac = G_vernac.subgoal_command -> tac g ] ] - ; - command: - [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; - l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] -> - Vernacexpr.VernacProof (Some (in_tac ta), G_proofs.hint_proof_using G_vernac.section_subset_expr l) - | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; - ta = OPT [ "with"; ta = Pltac.tactic -> in_tac ta ] -> - Vernacexpr.VernacProof (ta,Some l) ] ] - ; - hint: - [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; - tac = Pltac.tactic -> - Vernacexpr.HintsExtern (n,c, in_tac tac) ] ] - ; - operconstr: LEVEL "0" - [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> - let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in - CHole (!@loc, None, IntroAnonymous, Some arg) ] ] - ; - END - -open Stdarg -open Tacarg -open Vernacexpr -open Vernac_classifier -open Goptions -open Libnames - -let print_info_trace = ref None - -let _ = declare_int_option { - optsync = true; - optdepr = false; - optname = "print info trace"; - optkey = ["Info" ; "Level"]; - optread = (fun () -> !print_info_trace); - optwrite = fun n -> print_info_trace := n; -} - -let vernac_solve n info tcom b = - let status = Proof_global.with_current_proof (fun etac p -> - let with_end_tac = if b then Some etac else None in - let global = match n with SelectAll | SelectList _ -> true | _ -> false in - let info = Option.append info !print_info_trace in - let (p,status) = - Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p - in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus Vernacentries.command_focus p in - p,status) in - if not status then Feedback.feedback Feedback.AddedAxiom - -let pr_range_selector (i, j) = - if Int.equal i j then int i - else int i ++ str "-" ++ int j - -let pr_ltac_selector = function -| SelectNth i -> int i ++ str ":" -| SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ - str "]" ++ str ":" -| SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" -| SelectAll -> str "all" ++ str ":" - -VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector -| [ toplevel_selector(s) ] -> [ s ] -END - -let pr_ltac_info n = str "Info" ++ spc () ++ int n - -VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info -| [ "Info" natural(n) ] -> [ n ] -END - -let pr_ltac_use_default b = - if b then (* Bug: a space is inserted before "..." *) str ".." else mt () - -VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default -| [ "." ] -> [ false ] -| [ "..." ] -> [ true ] -END - -let is_anonymous_abstract = function - | TacAbstract (_,None) -> true - | TacSolve [TacAbstract (_,None)] -> true - | _ -> false -let rm_abstract = function - | TacAbstract (t,_) -> t - | TacSolve [TacAbstract (t,_)] -> TacSolve [t] - | x -> x -let is_explicit_terminator = function TacSolve _ -> true | _ -> false - -VERNAC tactic_mode EXTEND VernacSolve -| [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => - [ classify_as_proofstep ] -> [ - let g = Option.default (Proof_global.get_default_goal_selector ()) g in - vernac_solve g n t def - ] -| [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => - [ - let anon_abstracting_tac = is_anonymous_abstract t in - let solving_tac = is_explicit_terminator t in - let parallel = `Yes (solving_tac,anon_abstracting_tac) in - let pbr = if solving_tac then Some "par" else None in - VtProofStep{ parallel = parallel; proof_block_detection = pbr }, - VtLater - ] -> [ - let t = rm_abstract t in - vernac_solve SelectAll n t def - ] -END - -let pr_ltac_tactic_level n = str "(at level " ++ int n ++ str ")" - -VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY pr_ltac_tactic_level -| [ "(" "at" "level" natural(n) ")" ] -> [ n ] -END - -VERNAC ARGUMENT EXTEND ltac_production_sep -| [ "," string(sep) ] -> [ sep ] -END - -let pr_ltac_production_item = function -| Tacentries.TacTerm s -> quote (str s) -| Tacentries.TacNonTerm (_, (arg, sep), id) -> - let sep = match sep with - | None -> mt () - | Some sep -> str "," ++ spc () ++ quote (str sep) - in - str arg ++ str "(" ++ Nameops.pr_id id ++ sep ++ str ")" - -VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item -| [ string(s) ] -> [ Tacentries.TacTerm s ] -| [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> - [ Tacentries.TacNonTerm (loc, (Names.Id.to_string nt, sep), p) ] -END - -VERNAC COMMAND EXTEND VernacTacticNotation -| [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => - [ VtUnknown, VtNow ] -> - [ - let l = Locality.LocalityFixme.consume () in - let n = Option.default 0 n in - Tacentries.add_tactic_notation (Locality.make_module_locality l) n r e - ] -END - -VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY -| [ "Print" "Ltac" reference(r) ] -> - [ Feedback.msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ] -END - -let pr_ltac_ref = Libnames.pr_reference - -let pr_tacdef_body tacdef_body = - let id, redef, body = - match tacdef_body with - | TacticDefinition ((_,id), body) -> Nameops.pr_id id, false, body - | TacticRedefinition (id, body) -> pr_ltac_ref id, true, body - in - let idl, body = - match body with - | Tacexpr.TacFun (idl,b) -> idl,b - | _ -> [], body in - id ++ - prlist (function None -> str " _" - | Some id -> spc () ++ Nameops.pr_id id) idl - ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) - ++ Pptactic.pr_raw_tactic body - -VERNAC ARGUMENT EXTEND ltac_tacdef_body -PRINTED BY pr_tacdef_body -| [ tacdef_body(t) ] -> [ t ] -END - -VERNAC COMMAND EXTEND VernacDeclareTacticDefinition -| [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => [ - VtSideff (List.map (function - | TacticDefinition ((_,r),_) -> r - | TacticRedefinition (Ident (_,r),_) -> r - | TacticRedefinition (Qualid (_,q),_) -> snd(repr_qualid q)) l), VtLater - ] -> [ - let lc = Locality.LocalityFixme.consume () in - Tacentries.register_ltac (Locality.make_module_locality lc) l - ] -END - -VERNAC COMMAND EXTEND VernacPrintLtacs CLASSIFIED AS QUERY -| [ "Print" "Ltac" "Signatures" ] -> [ Tacentries.print_ltacs () ] -END diff --git a/ltac/g_obligations.ml4 b/ltac/g_obligations.ml4 deleted file mode 100644 index d286a5870..000000000 --- a/ltac/g_obligations.ml4 +++ /dev/null @@ -1,161 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - snd (get_default_tactic ()) - end in - Obligations.default_tactic := tac - -let with_tac f tac = - let env = { Genintern.genv = Global.env (); ltacvars = Names.Id.Set.empty } in - let tac = match tac with - | None -> None - | Some tac -> - let tac = Genarg.in_gen (Genarg.rawwit wit_ltac) tac in - let _, tac = Genintern.generic_intern env tac in - Some tac - in - f tac - -(* We define new entries for programs, with the use of this module - * Subtac. These entries are named Subtac. - *) - -module Gram = Pcoq.Gram -module Tactic = Pltac - -open Pcoq - -let sigref = mkRefC (Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Init.Specif.sig")) - -type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type - -let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = - Genarg.create_arg "withtac" - -let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac) - -GEXTEND Gram - GLOBAL: withtac; - - withtac: - [ [ "with"; t = Tactic.tactic -> Some t - | -> None ] ] - ; - - Constr.closed_binder: - [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> - let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in - [LocalRawAssum ([id], default_binder_kind, typ)] - ] ]; - - END - -open Obligations - -let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac -let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac - -let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) - -VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl -| [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> - [ obligation (num, Some name, Some t) tac ] -| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> - [ obligation (num, Some name, None) tac ] -| [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> - [ obligation (num, None, Some t) tac ] -| [ "Obligation" integer(num) withtac(tac) ] -> - [ obligation (num, None, None) tac ] -| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> - [ next_obligation (Some name) tac ] -| [ "Next" "Obligation" withtac(tac) ] -> [ next_obligation None tac ] -END - -VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF -| [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] -> - [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligation" integer(num) "with" tactic(t) ] -> - [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] -END - -VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF -| [ "Solve" "Obligations" "of" ident(name) "with" tactic(t) ] -> - [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligations" "with" tactic(t) ] -> - [ try_solve_obligations None (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligations" ] -> - [ try_solve_obligations None None ] -END - -VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF -| [ "Solve" "All" "Obligations" "with" tactic(t) ] -> - [ solve_all_obligations (Some (Tacinterp.interp t)) ] -| [ "Solve" "All" "Obligations" ] -> - [ solve_all_obligations None ] -END - -VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF -| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] -| [ "Admit" "Obligations" ] -> [ admit_obligations None ] -END - -VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF -| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ - set_default_tactic - (Locality.make_section_locality (Locality.LocalityFixme.consume ())) - (Tacintern.glob_tactic t) ] -END - -open Pp - -VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY -| [ "Show" "Obligation" "Tactic" ] -> [ - Feedback.msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ] -END - -VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY -| [ "Obligations" "of" ident(name) ] -> [ show_obligations (Some name) ] -| [ "Obligations" ] -> [ show_obligations None ] -END - -VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY -| [ "Preterm" "of" ident(name) ] -> [ Feedback.msg_info (show_term (Some name)) ] -| [ "Preterm" ] -> [ Feedback.msg_info (show_term None) ] -END - -open Pp - -(* Declare a printer for the content of Program tactics *) -let () = - let printer _ _ _ = function - | None -> mt () - | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac - in - (* should not happen *) - let dummy _ _ _ expr = assert false in - Pptactic.declare_extra_genarg_pprule wit_withtac printer dummy dummy diff --git a/ltac/g_rewrite.ml4 b/ltac/g_rewrite.ml4 deleted file mode 100644 index b1c4f58eb..000000000 --- a/ltac/g_rewrite.ml4 +++ /dev/null @@ -1,274 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ bl ] -END - -type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast -type glob_strategy = (Tacexpr.glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast - -let interp_strategy ist gl s = - let sigma = project gl in - sigma, strategy_of_ast s -let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s -let subst_strategy s str = str - -let pr_strategy _ _ _ (s : strategy) = Pp.str "" -let pr_raw_strategy prc prlc _ (s : raw_strategy) = - let prr = Pptactic.pr_red_expr (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_reference, prc) in - Rewrite.pr_strategy prc prr s -let pr_glob_strategy prc prlc _ (s : glob_strategy) = - let prr = Pptactic.pr_red_expr - (Ppconstr.pr_constr_expr, - Ppconstr.pr_lconstr_expr, - Pputils.pr_or_by_notation Libnames.pr_reference, - Ppconstr.pr_constr_expr) - in - Rewrite.pr_strategy prc prr s - -ARGUMENT EXTEND rewstrategy - PRINTED BY pr_strategy - - INTERPRETED BY interp_strategy - GLOBALIZED BY glob_strategy - SUBSTITUTED BY subst_strategy - - RAW_PRINTED BY pr_raw_strategy - GLOB_PRINTED BY pr_glob_strategy - - [ glob(c) ] -> [ StratConstr (c, true) ] - | [ "<-" constr(c) ] -> [ StratConstr (c, false) ] - | [ "subterms" rewstrategy(h) ] -> [ StratUnary (Subterms, h) ] - | [ "subterm" rewstrategy(h) ] -> [ StratUnary (Subterm, h) ] - | [ "innermost" rewstrategy(h) ] -> [ StratUnary(Innermost, h) ] - | [ "outermost" rewstrategy(h) ] -> [ StratUnary(Outermost, h) ] - | [ "bottomup" rewstrategy(h) ] -> [ StratUnary(Bottomup, h) ] - | [ "topdown" rewstrategy(h) ] -> [ StratUnary(Topdown, h) ] - | [ "id" ] -> [ StratId ] - | [ "fail" ] -> [ StratFail ] - | [ "refl" ] -> [ StratRefl ] - | [ "progress" rewstrategy(h) ] -> [ StratUnary (Progress, h) ] - | [ "try" rewstrategy(h) ] -> [ StratUnary (Try, h) ] - | [ "any" rewstrategy(h) ] -> [ StratUnary (Any, h) ] - | [ "repeat" rewstrategy(h) ] -> [ StratUnary (Repeat, h) ] - | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary (Compose, h, h') ] - | [ "(" rewstrategy(h) ")" ] -> [ h ] - | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary (Choice, h, h') ] - | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ] - | [ "hints" preident(h) ] -> [ StratHints (false, h) ] - | [ "terms" constr_list(h) ] -> [ StratTerms h ] - | [ "eval" red_expr(r) ] -> [ StratEval r ] - | [ "fold" constr(c) ] -> [ StratFold c ] -END - -(* By default the strategy for "rewrite_db" is top-down *) - -let db_strat db = StratUnary (Topdown, StratHints (false, db)) -let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db)) - -TACTIC EXTEND rewrite_strat -| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ] -| [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ] -| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ cl_rewrite_clause_db db (Some id) ] -| [ "rewrite_db" preident(db) ] -> [ cl_rewrite_clause_db db None ] -END - -let clsubstitute o c = - let is_tac id = match fst (fst (snd c)) with GVar (_, id') when Id.equal id' id -> true | _ -> false in - Tacticals.onAllHypsAndConcl - (fun cl -> - match cl with - | Some id when is_tac id -> tclIDTAC - | _ -> Proofview.V82.of_tactic (cl_rewrite_clause c o AllOccurrences cl)) - -TACTIC EXTEND substitute -| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ Proofview.V82.tactic (clsubstitute o c) ] -END - - -(* Compatibility with old Setoids *) - -TACTIC EXTEND setoid_rewrite - [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ] - -> [ cl_rewrite_clause c o AllOccurrences None ] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> - [ cl_rewrite_clause c o AllOccurrences (Some id) ] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> - [ cl_rewrite_clause c o (occurrences_of occ) None ] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> - [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] -> - [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] -END - -VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ] - - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) None None ] - | [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> - [ declare_relation a aeq n None None None ] -END - -VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF - [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) - "as" ident(n) ] -> - [ declare_relation a aeq n None (Some lemma2) None ] - | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ] -END - -VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF - [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ] - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] - | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation a aeq n None None (Some lemma3) ] -END - -type binders_argtype = local_binder list - -let wit_binders = - (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type) - -let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders) - -let () = - let raw_printer _ _ _ l = Pp.pr_non_empty_arg Ppconstr.pr_binders l in - let printer _ _ _ _ = Pp.str "" in - Pptactic.declare_extra_genarg_pprule wit_binders raw_printer printer printer - -open Pcoq - -GEXTEND Gram - GLOBAL: binders; - binders: - [ [ b = Pcoq.Constr.binders -> b ] ]; -END - -VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) - "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) - "reflexivity" "proved" "by" constr(lemma1) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) None None ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None None None ] -END - -VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF - [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None (Some lemma2) None ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ] -END - -VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF - [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] -END - -VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF - [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] a aeq t n ] - | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders a aeq t n ] - | [ "Add" "Morphism" constr(m) ":" ident(n) ] - (* This command may or may not open a goal *) - => [ Vernacexpr.VtUnknown, Vernacexpr.VtNow ] - -> [ add_morphism_infer (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) m n ] - | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] - => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] - -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] m s n ] - | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) - "with" "signature" lconstr(s) "as" ident(n) ] - => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] - -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders m s n ] -END - -TACTIC EXTEND setoid_symmetry - [ "setoid_symmetry" ] -> [ setoid_symmetry ] - | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ] -END - -TACTIC EXTEND setoid_reflexivity -[ "setoid_reflexivity" ] -> [ setoid_reflexivity ] -END - -TACTIC EXTEND setoid_transitivity - [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ] -| [ "setoid_etransitivity" ] -> [ setoid_transitivity None ] -END - -VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY - [ "Print" "Rewrite" "HintDb" preident(s) ] -> [ Feedback.msg_notice (Autorewrite.print_rewrite_hintdb s) ] -END diff --git a/ltac/g_tactic.ml4 b/ltac/g_tactic.ml4 deleted file mode 100644 index 685c07c9a..000000000 --- a/ltac/g_tactic.ml4 +++ /dev/null @@ -1,665 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* "; "<-" ; "by" ] -let _ = List.iter CLexer.add_keyword tactic_kw - -let err () = raise Stream.Failure - -(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) -(* admissible notation "(x t)" *) -let test_lpar_id_coloneq = - Gram.Entry.of_parser "lpar_id_coloneq" - (fun strm -> - match get_tok (stream_nth 0 strm) with - | KEYWORD "(" -> - (match get_tok (stream_nth 1 strm) with - | IDENT _ -> - (match get_tok (stream_nth 2 strm) with - | KEYWORD ":=" -> () - | _ -> err ()) - | _ -> err ()) - | _ -> err ()) - -(* Hack to recognize "(x)" *) -let test_lpar_id_rpar = - Gram.Entry.of_parser "lpar_id_coloneq" - (fun strm -> - match get_tok (stream_nth 0 strm) with - | KEYWORD "(" -> - (match get_tok (stream_nth 1 strm) with - | IDENT _ -> - (match get_tok (stream_nth 2 strm) with - | KEYWORD ")" -> () - | _ -> err ()) - | _ -> err ()) - | _ -> err ()) - -(* idem for (x:=t) and (1:=t) *) -let test_lpar_idnum_coloneq = - Gram.Entry.of_parser "test_lpar_idnum_coloneq" - (fun strm -> - match get_tok (stream_nth 0 strm) with - | KEYWORD "(" -> - (match get_tok (stream_nth 1 strm) with - | IDENT _ | INT _ -> - (match get_tok (stream_nth 2 strm) with - | KEYWORD ":=" -> () - | _ -> err ()) - | _ -> err ()) - | _ -> err ()) - -(* idem for (x:t) *) -let test_lpar_id_colon = - Gram.Entry.of_parser "lpar_id_colon" - (fun strm -> - match get_tok (stream_nth 0 strm) with - | KEYWORD "(" -> - (match get_tok (stream_nth 1 strm) with - | IDENT _ -> - (match get_tok (stream_nth 2 strm) with - | KEYWORD ":" -> () - | _ -> err ()) - | _ -> err ()) - | _ -> err ()) - -(* idem for (x1..xn:t) [n^2 complexity but exceptional use] *) -let check_for_coloneq = - Gram.Entry.of_parser "lpar_id_colon" - (fun strm -> - let rec skip_to_rpar p n = - match get_tok (List.last (Stream.npeek n strm)) with - | KEYWORD "(" -> skip_to_rpar (p+1) (n+1) - | KEYWORD ")" -> if Int.equal p 0 then n+1 else skip_to_rpar (p-1) (n+1) - | KEYWORD "." -> err () - | _ -> skip_to_rpar p (n+1) in - let rec skip_names n = - match get_tok (List.last (Stream.npeek n strm)) with - | IDENT _ | KEYWORD "_" -> skip_names (n+1) - | KEYWORD ":" -> skip_to_rpar 0 (n+1) (* skip a constr *) - | _ -> err () in - let rec skip_binders n = - match get_tok (List.last (Stream.npeek n strm)) with - | KEYWORD "(" -> skip_binders (skip_names (n+1)) - | IDENT _ | KEYWORD "_" -> skip_binders (n+1) - | KEYWORD ":=" -> () - | _ -> err () in - match get_tok (stream_nth 0 strm) with - | KEYWORD "(" -> skip_binders 2 - | _ -> err ()) - -let lookup_at_as_comma = - Gram.Entry.of_parser "lookup_at_as_comma" - (fun strm -> - match get_tok (stream_nth 0 strm) with - | KEYWORD (","|"at"|"as") -> () - | _ -> err ()) - -open Constr -open Prim -open Pltac - -let mk_fix_tac (loc,id,bl,ann,ty) = - let n = - match bl,ann with - [([_],_,_)], None -> 1 - | _, Some x -> - let ids = List.map snd (List.flatten (List.map pi1 bl)) in - (try List.index Names.Name.equal (snd x) ids - with Not_found -> error "No such fix variable.") - | _ -> error "Cannot guess decreasing argument of fix." in - (id,n,CProdN(loc,bl,ty)) - -let mk_cofix_tac (loc,id,bl,ann,ty) = - let _ = Option.map (fun (aloc,_) -> - user_err ~loc:aloc - ~hdr:"Constr:mk_cofix_tac" - (Pp.str"Annotation forbidden in cofix expression.")) ann in - (id,CProdN(loc,bl,ty)) - -(* Functions overloaded by quotifier *) -let destruction_arg_of_constr (c,lbind as clbind) = match lbind with - | NoBindings -> - begin - try ElimOnIdent (Constrexpr_ops.constr_loc c,snd(Constrexpr_ops.coerce_to_id c)) - with e when CErrors.noncritical e -> ElimOnConstr clbind - end - | _ -> ElimOnConstr clbind - -let mkTacCase with_evar = function - | [(clear,ElimOnConstr cl),(None,None),None],None -> - TacCase (with_evar,(clear,cl)) - (* Reinterpret numbers as a notation for terms *) - | [(clear,ElimOnAnonHyp n),(None,None),None],None -> - TacCase (with_evar, - (clear,(CPrim (Loc.ghost, Numeral (Bigint.of_int n)), - NoBindings))) - (* Reinterpret ident as notations for variables in the context *) - (* because we don't know if they are quantified or not *) - | [(clear,ElimOnIdent id),(None,None),None],None -> - TacCase (with_evar,(clear,(CRef (Ident id,None),NoBindings))) - | ic -> - if List.exists (function ((_, ElimOnAnonHyp _),_,_) -> true | _ -> false) (fst ic) - then - error "Use of numbers as direct arguments of 'case' is not supported."; - TacInductionDestruct (false,with_evar,ic) - -let rec mkCLambdaN_simple_loc loc bll c = - match bll with - | ((loc1,_)::_ as idl,bk,t) :: bll -> - CLambdaN (loc,[idl,bk,t],mkCLambdaN_simple_loc (Loc.merge loc1 loc) bll c) - | ([],_,_) :: bll -> mkCLambdaN_simple_loc loc bll c - | [] -> c - -let mkCLambdaN_simple bl c = match bl with - | [] -> c - | h :: _ -> - let loc = Loc.merge (fst (List.hd (pi1 h))) (Constrexpr_ops.constr_loc c) in - mkCLambdaN_simple_loc loc bl c - -let loc_of_ne_list l = Loc.merge (fst (List.hd l)) (fst (List.last l)) - -let map_int_or_var f = function - | ArgArg x -> ArgArg (f x) - | ArgVar _ as y -> y - -let all_concl_occs_clause = { onhyps=Some[]; concl_occs=AllOccurrences } - -let merge_occurrences loc cl = function - | None -> - if Locusops.clause_with_generic_occurrences cl then (None, cl) - else - user_err ~loc (str "Found an \"at\" clause without \"with\" clause.") - | Some (occs, p) -> - let ans = match occs with - | AllOccurrences -> cl - | _ -> - begin match cl with - | { onhyps = Some []; concl_occs = AllOccurrences } -> - { onhyps = Some []; concl_occs = occs } - | { onhyps = Some [(AllOccurrences, id), l]; concl_occs = NoOccurrences } -> - { cl with onhyps = Some [(occs, id), l] } - | _ -> - if Locusops.clause_with_generic_occurrences cl then - user_err ~loc (str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.") - else - user_err ~loc (str "Cannot use clause \"at\" twice.") - end - in - (Some p, ans) - -let warn_deprecated_eqn_syntax = - CWarnings.create ~name:"deprecated-eqn-syntax" ~category:"deprecated" - (fun arg -> strbrk (Printf.sprintf "Syntax \"_eqn:%s\" is deprecated. Please use \"eqn:%s\" instead." arg arg)) - -(* Auxiliary grammar rules *) - -open Vernac_ - -GEXTEND Gram - GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis - bindings red_expr int_or_var open_constr uconstr - simple_intropattern in_clause clause_dft_concl hypident destruction_arg; - - int_or_var: - [ [ n = integer -> ArgArg n - | id = identref -> ArgVar id ] ] - ; - nat_or_var: - [ [ n = natural -> ArgArg n - | id = identref -> ArgVar id ] ] - ; - (* An identifier or a quotation meta-variable *) - id_or_meta: - [ [ id = identref -> id ] ] - ; - open_constr: - [ [ c = constr -> c ] ] - ; - uconstr: - [ [ c = constr -> c ] ] - ; - destruction_arg: - [ [ n = natural -> (None,ElimOnAnonHyp n) - | test_lpar_id_rpar; c = constr_with_bindings -> - (Some false,destruction_arg_of_constr c) - | c = constr_with_bindings_arg -> on_snd destruction_arg_of_constr c - ] ] - ; - constr_with_bindings_arg: - [ [ ">"; c = constr_with_bindings -> (Some true,c) - | c = constr_with_bindings -> (None,c) ] ] - ; - quantified_hypothesis: - [ [ id = ident -> NamedHyp id - | n = natural -> AnonHyp n ] ] - ; - conversion: - [ [ c = constr -> (None, c) - | c1 = constr; "with"; c2 = constr -> (Some (AllOccurrences,c1),c2) - | c1 = constr; "at"; occs = occs_nums; "with"; c2 = constr -> - (Some (occs,c1), c2) ] ] - ; - occs_nums: - [ [ nl = LIST1 nat_or_var -> OnlyOccurrences nl - | "-"; n = nat_or_var; nl = LIST0 int_or_var -> - (* have used int_or_var instead of nat_or_var for compatibility *) - AllOccurrencesBut (List.map (map_int_or_var abs) (n::nl)) ] ] - ; - occs: - [ [ "at"; occs = occs_nums -> occs | -> AllOccurrences ] ] - ; - pattern_occ: - [ [ c = constr; nl = occs -> (nl,c) ] ] - ; - ref_or_pattern_occ: - (* If a string, it is interpreted as a ref - (anyway a Coq string does not reduce) *) - [ [ c = smart_global; nl = occs -> nl,Inl c - | c = constr; nl = occs -> nl,Inr c ] ] - ; - unfold_occ: - [ [ c = smart_global; nl = occs -> (nl,c) ] ] - ; - intropatterns: - [ [ l = LIST0 nonsimple_intropattern -> l ]] - ; - ne_intropatterns: - [ [ l = LIST1 nonsimple_intropattern -> l ]] - ; - or_and_intropattern: - [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> IntroOrPattern tc - | "()" -> IntroAndPattern [] - | "("; si = simple_intropattern; ")" -> IntroAndPattern [si] - | "("; si = simple_intropattern; ","; - tc = LIST1 simple_intropattern SEP "," ; ")" -> - IntroAndPattern (si::tc) - | "("; si = simple_intropattern; "&"; - tc = LIST1 simple_intropattern SEP "&" ; ")" -> - (* (A & B & C) is translated into (A,(B,C)) *) - let rec pairify = function - | ([]|[_]|[_;_]) as l -> l - | t::q -> [t;(loc_of_ne_list q,IntroAction (IntroOrAndPattern (IntroAndPattern (pairify q))))] - in IntroAndPattern (pairify (si::tc)) ] ] - ; - equality_intropattern: - [ [ "->" -> IntroRewrite true - | "<-" -> IntroRewrite false - | "[="; tc = intropatterns; "]" -> IntroInjection tc ] ] - ; - naming_intropattern: - [ [ prefix = pattern_ident -> IntroFresh prefix - | "?" -> IntroAnonymous - | id = ident -> IntroIdentifier id ] ] - ; - nonsimple_intropattern: - [ [ l = simple_intropattern -> l - | "*" -> !@loc, IntroForthcoming true - | "**" -> !@loc, IntroForthcoming false ]] - ; - simple_intropattern: - [ [ pat = simple_intropattern_closed; - l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> - let loc0,pat = pat in - let f c pat = - let loc = Loc.merge loc0 (Constrexpr_ops.constr_loc c) in - IntroAction (IntroApplyOn (c,(loc,pat))) in - !@loc, List.fold_right f l pat ] ] - ; - simple_intropattern_closed: - [ [ pat = or_and_intropattern -> !@loc, IntroAction (IntroOrAndPattern pat) - | pat = equality_intropattern -> !@loc, IntroAction pat - | "_" -> !@loc, IntroAction IntroWildcard - | pat = naming_intropattern -> !@loc, IntroNaming pat ] ] - ; - simple_binding: - [ [ "("; id = ident; ":="; c = lconstr; ")" -> (!@loc, NamedHyp id, c) - | "("; n = natural; ":="; c = lconstr; ")" -> (!@loc, AnonHyp n, c) ] ] - ; - bindings: - [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> - ExplicitBindings bl - | bl = LIST1 constr -> ImplicitBindings bl ] ] - ; - constr_with_bindings: - [ [ c = constr; l = with_bindings -> (c, l) ] ] - ; - with_bindings: - [ [ "with"; bl = bindings -> bl | -> NoBindings ] ] - ; - red_flags: - [ [ IDENT "beta" -> [FBeta] - | IDENT "iota" -> [FMatch;FFix;FCofix] - | IDENT "match" -> [FMatch] - | IDENT "fix" -> [FFix] - | IDENT "cofix" -> [FCofix] - | IDENT "zeta" -> [FZeta] - | IDENT "delta"; d = delta_flag -> [d] - ] ] - ; - delta_flag: - [ [ "-"; "["; idl = LIST1 smart_global; "]" -> FDeltaBut idl - | "["; idl = LIST1 smart_global; "]" -> FConst idl - | -> FDeltaBut [] - ] ] - ; - strategy_flag: - [ [ s = LIST1 red_flags -> Redops.make_red_flag (List.flatten s) - | d = delta_flag -> all_with d - ] ] - ; - red_expr: - [ [ IDENT "red" -> Red false - | IDENT "hnf" -> Hnf - | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ -> Simpl (all_with d,po) - | IDENT "cbv"; s = strategy_flag -> Cbv s - | IDENT "cbn"; s = strategy_flag -> Cbn s - | IDENT "lazy"; s = strategy_flag -> Lazy s - | IDENT "compute"; delta = delta_flag -> Cbv (all_with delta) - | IDENT "vm_compute"; po = OPT ref_or_pattern_occ -> CbvVm po - | IDENT "native_compute"; po = OPT ref_or_pattern_occ -> CbvNative po - | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul - | IDENT "fold"; cl = LIST1 constr -> Fold cl - | IDENT "pattern"; pl = LIST1 pattern_occ SEP"," -> Pattern pl - | s = IDENT -> ExtraRedExpr s ] ] - ; - hypident: - [ [ id = id_or_meta -> - id,InHyp - | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" -> - id,InHypTypeOnly - | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" -> - id,InHypValueOnly - ] ] - ; - hypident_occ: - [ [ (id,l)=hypident; occs=occs -> ((occs,id),l) ] ] - ; - in_clause: - [ [ "*"; occs=occs -> - {onhyps=None; concl_occs=occs} - | "*"; "|-"; occs=concl_occ -> - {onhyps=None; concl_occs=occs} - | hl=LIST0 hypident_occ SEP","; "|-"; occs=concl_occ -> - {onhyps=Some hl; concl_occs=occs} - | hl=LIST0 hypident_occ SEP"," -> - {onhyps=Some hl; concl_occs=NoOccurrences} ] ] - ; - clause_dft_concl: - [ [ "in"; cl = in_clause -> cl - | occs=occs -> {onhyps=Some[]; concl_occs=occs} - | -> all_concl_occs_clause ] ] - ; - clause_dft_all: - [ [ "in"; cl = in_clause -> cl - | -> {onhyps=None; concl_occs=AllOccurrences} ] ] - ; - opt_clause: - [ [ "in"; cl = in_clause -> Some cl - | "at"; occs = occs_nums -> Some {onhyps=Some[]; concl_occs=occs} - | -> None ] ] - ; - concl_occ: - [ [ "*"; occs = occs -> occs - | -> NoOccurrences ] ] - ; - in_hyp_list: - [ [ "in"; idl = LIST1 id_or_meta -> idl - | -> [] ] ] - ; - in_hyp_as: - [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (id,ipat) - | -> None ] ] - ; - orient: - [ [ "->" -> true - | "<-" -> false - | -> true ]] - ; - simple_binder: - [ [ na=name -> ([na],Default Explicit,CHole (!@loc, Some (Evar_kinds.BinderType (snd na)), IntroAnonymous, None)) - | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> (nal,Default Explicit,c) - ] ] - ; - fixdecl: - [ [ "("; id = ident; bl=LIST0 simple_binder; ann=fixannot; - ":"; ty=lconstr; ")" -> (!@loc, id, bl, ann, ty) ] ] - ; - fixannot: - [ [ "{"; IDENT "struct"; id=name; "}" -> Some id - | -> None ] ] - ; - cofixdecl: - [ [ "("; id = ident; bl=LIST0 simple_binder; ":"; ty=lconstr; ")" -> - (!@loc, id, bl, None, ty) ] ] - ; - bindings_with_parameters: - [ [ check_for_coloneq; "("; id = ident; bl = LIST0 simple_binder; - ":="; c = lconstr; ")" -> (id, mkCLambdaN_simple bl c) ] ] - ; - eliminator: - [ [ "using"; el = constr_with_bindings -> el ] ] - ; - as_ipat: - [ [ "as"; ipat = simple_intropattern -> Some ipat - | -> None ] ] - ; - or_and_intropattern_loc: - [ [ ipat = or_and_intropattern -> ArgArg (!@loc,ipat) - | locid = identref -> ArgVar locid ] ] - ; - as_or_and_ipat: - [ [ "as"; ipat = or_and_intropattern_loc -> Some ipat - | -> None ] ] - ; - eqn_ipat: - [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> Some (!@loc, pat) - | IDENT "_eqn"; ":"; pat = naming_intropattern -> - let loc = !@loc in - warn_deprecated_eqn_syntax ~loc "H"; Some (loc, pat) - | IDENT "_eqn" -> - let loc = !@loc in - warn_deprecated_eqn_syntax ~loc "?"; Some (loc, IntroAnonymous) - | -> None ] ] - ; - as_name: - [ [ "as"; id = ident -> Names.Name id | -> Names.Anonymous ] ] - ; - by_tactic: - [ [ "by"; tac = tactic_expr LEVEL "3" -> Some tac - | -> None ] ] - ; - rewriter : - [ [ "!"; c = constr_with_bindings_arg -> (RepeatPlus,c) - | ["?"| LEFTQMARK]; c = constr_with_bindings_arg -> (RepeatStar,c) - | n = natural; "!"; c = constr_with_bindings_arg -> (Precisely n,c) - | n = natural; ["?" | LEFTQMARK]; c = constr_with_bindings_arg -> (UpTo n,c) - | n = natural; c = constr_with_bindings_arg -> (Precisely n,c) - | c = constr_with_bindings_arg -> (Precisely 1, c) - ] ] - ; - oriented_rewriter : - [ [ b = orient; p = rewriter -> let (m,c) = p in (b,m,c) ] ] - ; - induction_clause: - [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; - cl = opt_clause -> (c,(eq,pat),cl) ] ] - ; - induction_clause_list: - [ [ ic = LIST1 induction_clause SEP ","; el = OPT eliminator; - cl_tolerance = opt_clause -> - (* Condition for accepting "in" at the end by compatibility *) - match ic,el,cl_tolerance with - | [c,pat,None],Some _,Some _ -> ([c,pat,cl_tolerance],el) - | _,_,Some _ -> err () - | _,_,None -> (ic,el) ]] - ; - simple_tactic: - [ [ - (* Basic tactics *) - IDENT "intros"; pl = ne_intropatterns -> - TacAtom (!@loc, TacIntroPattern (false,pl)) - | IDENT "intros" -> - TacAtom (!@loc, TacIntroPattern (false,[!@loc,IntroForthcoming false])) - | IDENT "eintros"; pl = ne_intropatterns -> - TacAtom (!@loc, TacIntroPattern (true,pl)) - - | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,false,cl,inhyp)) - | IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,true,cl,inhyp)) - | IDENT "simple"; IDENT "apply"; - cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,false,cl,inhyp)) - | IDENT "simple"; IDENT "eapply"; - cl = LIST1 constr_with_bindings_arg SEP","; - inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,true,cl,inhyp)) - | IDENT "elim"; cl = constr_with_bindings_arg; el = OPT eliminator -> - TacAtom (!@loc, TacElim (false,cl,el)) - | IDENT "eelim"; cl = constr_with_bindings_arg; el = OPT eliminator -> - TacAtom (!@loc, TacElim (true,cl,el)) - | IDENT "case"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase false icl) - | IDENT "ecase"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase true icl) - | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> - TacAtom (!@loc, TacMutualFix (id,n,List.map mk_fix_tac fd)) - | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> - TacAtom (!@loc, TacMutualCofix (id,List.map mk_cofix_tac fd)) - - | IDENT "pose"; (id,b) = bindings_with_parameters -> - TacAtom (!@loc, TacLetTac (Names.Name id,b,Locusops.nowhere,true,None)) - | IDENT "pose"; b = constr; na = as_name -> - TacAtom (!@loc, TacLetTac (na,b,Locusops.nowhere,true,None)) - | IDENT "set"; (id,c) = bindings_with_parameters; p = clause_dft_concl -> - TacAtom (!@loc, TacLetTac (Names.Name id,c,p,true,None)) - | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl -> - TacAtom (!@loc, TacLetTac (na,c,p,true,None)) - | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat; - p = clause_dft_all -> - TacAtom (!@loc, TacLetTac (na,c,p,false,e)) - - (* Alternative syntax for "pose proof c as id" *) - | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":="; - c = lconstr; ")" -> - TacAtom (!@loc, TacAssert (true,None,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) - - (* Alternative syntax for "assert c as id by tac" *) - | IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; - c = lconstr; ")"; tac=by_tactic -> - TacAtom (!@loc, TacAssert (true,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) - - (* Alternative syntax for "enough c as id by tac" *) - | IDENT "enough"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; - c = lconstr; ")"; tac=by_tactic -> - TacAtom (!@loc, TacAssert (false,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) - - | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAtom (!@loc, TacAssert (true,Some tac,ipat,c)) - | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - TacAtom (!@loc, TacAssert (true,None,ipat,c)) - | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAtom (!@loc, TacAssert (false,Some tac,ipat,c)) - - | IDENT "generalize"; c = constr -> - TacAtom (!@loc, TacGeneralize [((AllOccurrences,c),Names.Anonymous)]) - | IDENT "generalize"; c = constr; l = LIST1 constr -> - let gen_everywhere c = ((AllOccurrences,c),Names.Anonymous) in - TacAtom (!@loc, TacGeneralize (List.map gen_everywhere (c::l))) - | IDENT "generalize"; c = constr; lookup_at_as_comma; nl = occs; - na = as_name; - l = LIST0 [","; c = pattern_occ; na = as_name -> (c,na)] -> - TacAtom (!@loc, TacGeneralize (((nl,c),na)::l)) - - (* Derived basic tactics *) - | IDENT "induction"; ic = induction_clause_list -> - TacAtom (!@loc, TacInductionDestruct (true,false,ic)) - | IDENT "einduction"; ic = induction_clause_list -> - TacAtom (!@loc, TacInductionDestruct(true,true,ic)) - | IDENT "destruct"; icl = induction_clause_list -> - TacAtom (!@loc, TacInductionDestruct(false,false,icl)) - | IDENT "edestruct"; icl = induction_clause_list -> - TacAtom (!@loc, TacInductionDestruct(false,true,icl)) - - (* Equality and inversion *) - | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> TacAtom (!@loc, TacRewrite (false,l,cl,t)) - | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> TacAtom (!@loc, TacRewrite (true,l,cl,t)) - | IDENT "dependent"; k = - [ IDENT "simple"; IDENT "inversion" -> SimpleInversion - | IDENT "inversion" -> FullInversion - | IDENT "inversion_clear" -> FullInversionClear ]; - hyp = quantified_hypothesis; - ids = as_or_and_ipat; co = OPT ["with"; c = constr -> c] -> - TacAtom (!@loc, TacInversion (DepInversion (k,co,ids),hyp)) - | IDENT "simple"; IDENT "inversion"; - hyp = quantified_hypothesis; ids = as_or_and_ipat; - cl = in_hyp_list -> - TacAtom (!@loc, TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) - | IDENT "inversion"; - hyp = quantified_hypothesis; ids = as_or_and_ipat; - cl = in_hyp_list -> - TacAtom (!@loc, TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) - | IDENT "inversion_clear"; - hyp = quantified_hypothesis; ids = as_or_and_ipat; - cl = in_hyp_list -> - TacAtom (!@loc, TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) - | IDENT "inversion"; hyp = quantified_hypothesis; - "using"; c = constr; cl = in_hyp_list -> - TacAtom (!@loc, TacInversion (InversionUsing (c,cl), hyp)) - - (* Conversion *) - | IDENT "red"; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Red false, cl)) - | IDENT "hnf"; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Hnf, cl)) - | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Simpl (all_with d, po), cl)) - | IDENT "cbv"; s = strategy_flag; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Cbv s, cl)) - | IDENT "cbn"; s = strategy_flag; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Cbn s, cl)) - | IDENT "lazy"; s = strategy_flag; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Lazy s, cl)) - | IDENT "compute"; delta = delta_flag; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Cbv (all_with delta), cl)) - | IDENT "vm_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (CbvVm po, cl)) - | IDENT "native_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (CbvNative po, cl)) - | IDENT "unfold"; ul = LIST1 unfold_occ SEP ","; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Unfold ul, cl)) - | IDENT "fold"; l = LIST1 constr; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Fold l, cl)) - | IDENT "pattern"; pl = LIST1 pattern_occ SEP","; cl = clause_dft_concl -> - TacAtom (!@loc, TacReduce (Pattern pl, cl)) - - (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) - | IDENT "change"; (oc,c) = conversion; cl = clause_dft_concl -> - let p,cl = merge_occurrences (!@loc) cl oc in - TacAtom (!@loc, TacChange (p,c,cl)) - ] ] - ; -END;; diff --git a/ltac/ltac.mllib b/ltac/ltac.mllib deleted file mode 100644 index af1c7149d..000000000 --- a/ltac/ltac.mllib +++ /dev/null @@ -1,27 +0,0 @@ -Tacarg -Pptactic -Pltac -Taccoerce -Tacsubst -Tacenv -Tactic_debug -Tacintern -Tacentries -Profile_ltac -Tactic_matching -Tacinterp -Evar_tactics -Tactic_option -Extraargs -G_obligations -Coretactics -Extratactics -Profile_ltac_tactics -G_auto -G_class -Rewrite -G_rewrite -Tauto -G_eqdecide -G_tactic -G_ltac diff --git a/ltac/pltac.ml b/ltac/pltac.ml deleted file mode 100644 index 1d21118ae..000000000 --- a/ltac/pltac.ml +++ /dev/null @@ -1,65 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Gram.entry table *) -(* Typically for tactic user extensions *) -let open_constr = - make_gen_entry utactic "open_constr" -let constr_with_bindings = - make_gen_entry utactic "constr_with_bindings" -let bindings = - make_gen_entry utactic "bindings" -let hypident = Gram.entry_create "hypident" -let constr_may_eval = make_gen_entry utactic "constr_may_eval" -let constr_eval = make_gen_entry utactic "constr_eval" -let uconstr = - make_gen_entry utactic "uconstr" -let quantified_hypothesis = - make_gen_entry utactic "quantified_hypothesis" -let destruction_arg = make_gen_entry utactic "destruction_arg" -let int_or_var = make_gen_entry utactic "int_or_var" -let simple_intropattern = - make_gen_entry utactic "simple_intropattern" -let in_clause = make_gen_entry utactic "in_clause" -let clause_dft_concl = - make_gen_entry utactic "clause" - - -(* Main entries for ltac *) -let tactic_arg = Gram.entry_create "tactic:tactic_arg" -let tactic_expr = make_gen_entry utactic "tactic_expr" -let binder_tactic = make_gen_entry utactic "binder_tactic" - -let tactic = make_gen_entry utactic "tactic" - -(* Main entry for quotations *) -let tactic_eoi = eoi_entry tactic - -let () = - let open Stdarg in - let open Tacarg in - register_grammar wit_int_or_var (int_or_var); - register_grammar wit_intro_pattern (simple_intropattern); - register_grammar wit_quant_hyp (quantified_hypothesis); - register_grammar wit_uconstr (uconstr); - register_grammar wit_open_constr (open_constr); - register_grammar wit_constr_with_bindings (constr_with_bindings); - register_grammar wit_bindings (bindings); - register_grammar wit_tactic (tactic); - register_grammar wit_ltac (tactic); - register_grammar wit_clause_dft_concl (clause_dft_concl); - register_grammar wit_destruction_arg (destruction_arg); - () diff --git a/ltac/pltac.mli b/ltac/pltac.mli deleted file mode 100644 index 810e1ec39..000000000 --- a/ltac/pltac.mli +++ /dev/null @@ -1,38 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - (tolerability -> raw_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds - -type 'a glob_extra_genarg_printer = - (glob_constr_and_expr -> std_ppcmds) -> - (glob_constr_and_expr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds - -type 'a extra_genarg_printer = - (Term.constr -> std_ppcmds) -> - (Term.constr -> std_ppcmds) -> - (tolerability -> Val.t -> std_ppcmds) -> - 'a -> std_ppcmds - -module Make - (Ppconstr : Ppconstrsig.Pp) - (Taggers : sig - val tag_keyword - : std_ppcmds -> std_ppcmds - val tag_primitive - : std_ppcmds -> std_ppcmds - val tag_string - : std_ppcmds -> std_ppcmds - val tag_glob_tactic_expr - : glob_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_glob_atomic_tactic_expr - : glob_atomic_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_raw_tactic_expr - : raw_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_raw_atomic_tactic_expr - : raw_atomic_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_atomic_tactic_expr - : atomic_tactic_expr -> std_ppcmds -> std_ppcmds - end) -= struct - - open Taggers - - let keyword x = tag_keyword (str x) - let primitive x = tag_primitive (str x) - - let has_type (Val.Dyn (tag, x)) t = match Val.eq tag t with - | None -> false - | Some _ -> true - - let unbox : type a. Val.t -> a Val.typ -> a= fun (Val.Dyn (tag, x)) t -> - match Val.eq tag t with - | None -> assert false - | Some Refl -> x - - let rec pr_value lev v : std_ppcmds = - if has_type v Val.typ_list then - pr_sequence (fun x -> pr_value lev x) (unbox v Val.typ_list) - else if has_type v Val.typ_opt then - pr_opt_no_spc (fun x -> pr_value lev x) (unbox v Val.typ_opt) - else if has_type v Val.typ_pair then - let (v1, v2) = unbox v Val.typ_pair in - str "(" ++ pr_value lev v1 ++ str ", " ++ pr_value lev v2 ++ str ")" - else - let Val.Dyn (tag, x) = v in - let name = Val.repr tag in - let default = str "<" ++ str name ++ str ">" in - match ArgT.name name with - | None -> default - | Some (ArgT.Any arg) -> - let wit = ExtraArg arg in - match val_tag (Topwit wit) with - | Val.Base t -> - begin match Val.eq t tag with - | None -> default - | Some Refl -> Genprint.generic_top_print (in_gen (Topwit wit) x) - end - | _ -> default - - let pr_with_occurrences pr c = pr_with_occurrences pr keyword c - let pr_red_expr pr c = pr_red_expr pr keyword c - - let pr_may_eval test prc prlc pr2 pr3 = function - | ConstrEval (r,c) -> - hov 0 - (keyword "eval" ++ brk (1,1) ++ - pr_red_expr (prc,prlc,pr2,pr3) r ++ spc () ++ - keyword "in" ++ spc() ++ prc c) - | ConstrContext ((_,id),c) -> - hov 0 - (keyword "context" ++ spc () ++ pr_id id ++ spc () ++ - str "[ " ++ prlc c ++ str " ]") - | ConstrTypeOf c -> - hov 1 (keyword "type of" ++ spc() ++ prc c) - | ConstrTerm c when test c -> - h 0 (str "(" ++ prc c ++ str ")") - | ConstrTerm c -> - prc c - - let pr_may_eval a = - pr_may_eval (fun _ -> false) a - - let pr_arg pr x = spc () ++ pr x - - let pr_and_short_name pr (c,_) = pr c - - let pr_or_by_notation f = function - | AN v -> f v - | ByNotation (_,s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc - - let pr_located pr (loc,x) = pr x - - let pr_evaluable_reference = function - | EvalVarRef id -> pr_id id - | EvalConstRef sp -> pr_global (Globnames.ConstRef sp) - - let pr_quantified_hypothesis = function - | AnonHyp n -> int n - | NamedHyp id -> pr_id id - - let pr_binding prc = function - | loc, NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c) - | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) - - let pr_bindings prc prlc = function - | ImplicitBindings l -> - brk (1,1) ++ keyword "with" ++ brk (1,1) ++ - hv 0 (prlist_with_sep spc prc l) - | ExplicitBindings l -> - brk (1,1) ++ keyword "with" ++ brk (1,1) ++ - hv 0 (prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l) - | NoBindings -> mt () - - let pr_bindings_no_with prc prlc = function - | ImplicitBindings l -> - brk (0,1) ++ - prlist_with_sep spc prc l - | ExplicitBindings l -> - brk (0,1) ++ - prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l - | NoBindings -> mt () - - let pr_clear_flag clear_flag pp x = - match clear_flag with - | Some false -> surround (pp x) - | Some true -> str ">" ++ pp x - | None -> pp x - - let pr_with_bindings prc prlc (c,bl) = - prc c ++ pr_bindings prc prlc bl - - let pr_with_bindings_arg prc prlc (clear_flag,c) = - pr_clear_flag clear_flag (pr_with_bindings prc prlc) c - - let pr_with_constr prc = function - | None -> mt () - | Some c -> spc () ++ hov 1 (keyword "with" ++ spc () ++ prc c) - - let pr_message_token prid = function - | MsgString s -> tag_string (qs s) - | MsgInt n -> int n - | MsgIdent id -> prid id - - let pr_fresh_ids = - prlist (fun s -> spc() ++ pr_or_var (fun s -> tag_string (qs s)) s) - - let with_evars ev s = if ev then "e" ^ s else s - - let rec tacarg_using_rule_token pr_gen = function - | [] -> [] - | TacTerm s :: l -> keyword s :: tacarg_using_rule_token pr_gen l - | TacNonTerm (_, (symb, arg), _) :: l -> - pr_gen symb arg :: tacarg_using_rule_token pr_gen l - - let pr_tacarg_using_rule pr_gen l = - let l = match l with - | TacTerm s :: l -> - (** First terminal token should be considered as the name of the tactic, - so we tag it differently than the other terminal tokens. *) - primitive s :: tacarg_using_rule_token pr_gen l - | _ -> tacarg_using_rule_token pr_gen l - in - pr_sequence (fun x -> x) l - - let pr_extend_gen pr_gen lev { mltac_name = s; mltac_index = i } l = - let name = - str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic ++ - str "@" ++ int i - in - let args = match l with - | [] -> mt () - | _ -> spc() ++ pr_sequence pr_gen l - in - str "<" ++ name ++ str ">" ++ args - - let rec pr_user_symbol = function - | Extend.Ulist1 tkn -> "ne_" ^ pr_user_symbol tkn ^ "_list" - | Extend.Ulist1sep (tkn, _) -> "ne_" ^ pr_user_symbol tkn ^ "_list" - | Extend.Ulist0 tkn -> pr_user_symbol tkn ^ "_list" - | Extend.Ulist0sep (tkn, _) -> pr_user_symbol tkn ^ "_list" - | Extend.Uopt tkn -> pr_user_symbol tkn ^ "_opt" - | Extend.Uentry tag -> - let ArgT.Any tag = tag in - ArgT.repr tag - | Extend.Uentryl (tkn, lvl) -> "tactic" ^ string_of_int lvl - - let pr_alias_key key = - try - let prods = (KNmap.find key !prnotation_tab).pptac_prods in - let rec pr = function - | TacTerm s -> primitive s - | TacNonTerm (_, symb, _) -> str (Printf.sprintf "(%s)" (pr_user_symbol symb)) - in - pr_sequence pr prods - with Not_found -> - KerName.print key - - let pr_alias_gen pr_gen lev key l = - try - let pp = KNmap.find key !prnotation_tab in - let rec pack prods args = match prods, args with - | [], [] -> [] - | TacTerm s :: prods, args -> TacTerm s :: pack prods args - | TacNonTerm (loc, symb, id) :: prods, arg :: args -> - TacNonTerm (loc, (symb, arg), id) :: pack prods args - | _ -> raise Not_found - in - let prods = pack pp.pptac_prods l in - let p = pr_tacarg_using_rule pr_gen prods in - if pp.pptac_level > lev then surround p else p - with Not_found -> - let pr arg = str "_" in - KerName.print key ++ spc() ++ pr_sequence pr l ++ str" (* Generic printer *)" - - let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.ghost, arg)) - - let is_genarg tag wit = - let ArgT.Any tag = tag in - argument_type_eq (ArgumentType (ExtraArg tag)) wit - - let get_list : type l. l generic_argument -> l generic_argument list option = - function (GenArg (wit, arg)) -> match wit with - | Rawwit (ListArg wit) -> Some (List.map (in_gen (rawwit wit)) arg) - | Glbwit (ListArg wit) -> Some (List.map (in_gen (glbwit wit)) arg) - | _ -> None - - let get_opt : type l. l generic_argument -> l generic_argument option option = - function (GenArg (wit, arg)) -> match wit with - | Rawwit (OptArg wit) -> Some (Option.map (in_gen (rawwit wit)) arg) - | Glbwit (OptArg wit) -> Some (Option.map (in_gen (glbwit wit)) arg) - | _ -> None - - let rec pr_any_arg : type l. (_ -> l generic_argument -> std_ppcmds) -> _ -> l generic_argument -> std_ppcmds = - fun prtac symb arg -> match symb with - | Extend.Uentry tag when is_genarg tag (genarg_tag arg) -> prtac (1, Any) arg - | Extend.Ulist1 s | Extend.Ulist0 s -> - begin match get_list arg with - | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" - | Some l -> pr_sequence (pr_any_arg prtac s) l - end - | Extend.Ulist1sep (s, sep) | Extend.Ulist0sep (s, sep) -> - begin match get_list arg with - | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" - | Some l -> prlist_with_sep (fun () -> str sep) (pr_any_arg prtac s) l - end - | Extend.Uopt s -> - begin match get_opt arg with - | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" - | Some l -> pr_opt (pr_any_arg prtac s) l - end - | Extend.Uentry _ | Extend.Uentryl _ -> - str "ltac:(" ++ prtac (1, Any) arg ++ str ")" - - let rec pr_targ prtac symb arg = match symb with - | Extend.Uentry tag when is_genarg tag (ArgumentType wit_tactic) -> - prtac (1, Any) arg - | Extend.Uentryl (_, l) -> prtac (l, Any) arg - | _ -> - match arg with - | TacGeneric arg -> - let pr l arg = prtac l (TacGeneric arg) in - pr_any_arg pr symb arg - | _ -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" - - let pr_raw_extend_rec prc prlc prtac prpat = - pr_extend_gen (pr_farg prtac) - let pr_glob_extend_rec prc prlc prtac prpat = - pr_extend_gen (pr_farg prtac) - - let pr_raw_alias prc prlc prtac prpat lev key args = - pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args - let pr_glob_alias prc prlc prtac prpat lev key args = - pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args - - (**********************************************************************) - (* The tactic printer *) - - let strip_prod_binders_expr n ty = - let rec strip_ty acc n ty = - match ty 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 - if nb >= n then (List.rev (bll@acc)), a - else strip_ty (bll@acc) (n-nb) a - | _ -> error "Cannot translate fix tactic: not enough products" in - strip_ty [] n ty - - let pr_ltac_or_var pr = function - | ArgArg x -> pr x - | ArgVar (loc,id) -> pr_with_comments loc (pr_id id) - - let pr_ltac_constant kn = - if !Flags.in_debugger then pr_kn kn - else try - pr_qualid (Nametab.shortest_qualid_of_tactic kn) - with Not_found -> (* local tactic not accessible anymore *) - str "<" ++ pr_kn kn ++ str ">" - - let pr_evaluable_reference_env env = function - | EvalVarRef id -> pr_id id - | EvalConstRef sp -> - Nametab.pr_global_env (Termops.vars_of_env env) (Globnames.ConstRef sp) - - let pr_esubst prc l = - let pr_qhyp = function - (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")" - | (_,NamedHyp id,c) -> - str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")" - in - prlist_with_sep spc pr_qhyp l - - let pr_bindings_gen for_ex prc prlc = function - | ImplicitBindings l -> - spc () ++ - hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++ - prlist_with_sep spc prc l) - | ExplicitBindings l -> - spc () ++ - hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++ - pr_esubst prlc l) - | NoBindings -> mt () - - let pr_bindings prc prlc = pr_bindings_gen false prc prlc - - let pr_with_bindings prc prlc (c,bl) = - hov 1 (prc c ++ pr_bindings prc prlc bl) - - let pr_as_disjunctive_ipat prc ipatl = - keyword "as" ++ spc () ++ - pr_or_var (fun (loc,p) -> Miscprint.pr_or_and_intro_pattern prc p) ipatl - - let pr_eqn_ipat (_,ipat) = keyword "eqn:" ++ Miscprint.pr_intro_pattern_naming ipat - - let pr_with_induction_names prc = function - | None, None -> mt () - | Some eqpat, None -> hov 1 (pr_eqn_ipat eqpat) - | None, Some ipat -> hov 1 (pr_as_disjunctive_ipat prc ipat) - | Some eqpat, Some ipat -> - hov 1 (pr_as_disjunctive_ipat prc ipat ++ spc () ++ pr_eqn_ipat eqpat) - - let pr_as_intro_pattern prc ipat = - spc () ++ hov 1 (keyword "as" ++ spc () ++ Miscprint.pr_intro_pattern prc ipat) - - let pr_with_inversion_names prc = function - | None -> mt () - | Some ipat -> pr_as_disjunctive_ipat prc ipat - - let pr_as_ipat prc = function - | None -> mt () - | Some ipat -> pr_as_intro_pattern prc ipat - - let pr_as_name = function - | Anonymous -> mt () - | Name id -> spc () ++ keyword "as" ++ spc () ++ pr_lident (Loc.ghost,id) - - let pr_pose_as_style prc na c = - spc() ++ prc c ++ pr_as_name na - - let pr_pose prc prlc na c = match na with - | Anonymous -> spc() ++ prc c - | Name id -> spc() ++ surround (pr_id id ++ str " :=" ++ spc() ++ prlc c) - - let pr_assertion prc prdc _prlc ipat c = match ipat with - (* Use this "optimisation" or use only the general case ? - | IntroIdentifier id -> - spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c) - *) - | ipat -> - spc() ++ prc c ++ pr_as_ipat prdc ipat - - let pr_assumption prc prdc prlc ipat c = match ipat with - (* Use this "optimisation" or use only the general case ?*) - (* it seems that this "optimisation" is somehow more natural *) - | Some (_,IntroNaming (IntroIdentifier id)) -> - spc() ++ surround (pr_id id ++ str " :" ++ spc() ++ prlc c) - | ipat -> - spc() ++ prc c ++ pr_as_ipat prdc ipat - - let pr_by_tactic prt = function - | Some tac -> keyword "by" ++ spc () ++ prt tac - | None -> mt() - - let pr_hyp_location pr_id = function - | occs, InHyp -> pr_with_occurrences pr_id occs - | occs, InHypTypeOnly -> - pr_with_occurrences (fun id -> - str "(" ++ keyword "type of" ++ spc () ++ pr_id id ++ str ")" - ) occs - | occs, InHypValueOnly -> - pr_with_occurrences (fun id -> - str "(" ++ keyword "value of" ++ spc () ++ pr_id id ++ str ")" - ) occs - - let pr_in pp = hov 0 (keyword "in" ++ pp) - - let pr_simple_hyp_clause pr_id = function - | [] -> mt () - | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l) - - let pr_in_hyp_as prc pr_id = function - | None -> mt () - | Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat - - let pr_in_clause pr_id = function - | { onhyps=None; concl_occs=NoOccurrences } -> - (str "* |-") - | { onhyps=None; concl_occs=occs } -> - (pr_with_occurrences (fun () -> str "*") (occs,())) - | { onhyps=Some l; concl_occs=NoOccurrences } -> - prlist_with_sep (fun () -> str ", ") (pr_hyp_location pr_id) l - | { onhyps=Some l; concl_occs=occs } -> - let pr_occs = pr_with_occurrences (fun () -> str" |- *") (occs,()) in - (prlist_with_sep (fun () -> str", ") (pr_hyp_location pr_id) l ++ pr_occs) - - let pr_clauses default_is_concl pr_id = function - | { onhyps=Some []; concl_occs=occs } - when (match default_is_concl with Some true -> true | _ -> false) -> - pr_with_occurrences mt (occs,()) - | { onhyps=None; concl_occs=AllOccurrences } - when (match default_is_concl with Some false -> true | _ -> false) -> mt () - | { onhyps=None; concl_occs=NoOccurrences } -> - pr_in (str " * |-") - | { onhyps=None; concl_occs=occs } -> - pr_in (pr_with_occurrences (fun () -> str " *") (occs,())) - | { onhyps=Some l; concl_occs=occs } -> - let pr_occs = match occs with - | NoOccurrences -> mt () - | _ -> pr_with_occurrences (fun () -> str" |- *") (occs,()) - in - pr_in - (prlist_with_sep (fun () -> str",") - (fun id -> spc () ++ pr_hyp_location pr_id id) l ++ pr_occs) - - let pr_orient b = if b then mt () else str "<- " - - let pr_multi = function - | Precisely 1 -> mt () - | Precisely n -> int n ++ str "!" - | UpTo n -> int n ++ str "?" - | RepeatStar -> str "?" - | RepeatPlus -> str "!" - - let pr_core_destruction_arg prc prlc = function - | ElimOnConstr c -> pr_with_bindings prc prlc c - | ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id) - | ElimOnAnonHyp n -> int n - - let pr_destruction_arg prc prlc (clear_flag,h) = - pr_clear_flag clear_flag (pr_core_destruction_arg prc prlc) h - - let pr_inversion_kind = function - | SimpleInversion -> primitive "simple inversion" - | FullInversion -> primitive "inversion" - | FullInversionClear -> primitive "inversion_clear" - - let pr_range_selector (i, j) = - if Int.equal i j then int i - else int i ++ str "-" ++ int j - - let pr_goal_selector = function - | SelectNth i -> int i ++ str ":" - | SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ - str "]" ++ str ":" - | SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" - | SelectAll -> str "all" ++ str ":" - - let pr_lazy = function - | General -> keyword "multi" - | Select -> keyword "lazy" - | Once -> mt () - - 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. *) - keyword "context" ++ str" [ " ++ pr_pat a ++ str " ]" - | Subterm (b,Some id,a) -> - keyword "context" ++ spc () ++ pr_id id ++ str "[ " ++ pr_pat a ++ str " ]" - - let pr_match_hyps pr_pat = function - | Hyp (nal,mp) -> - pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp - | Def (nal,mv,mp) -> - pr_lname nal ++ str ":=" ++ pr_match_pattern pr_pat mv - ++ str ":" ++ pr_match_pattern pr_pat mp - - let pr_match_rule m pr pr_pat = function - | Pat ([],mp,t) when m -> - pr_match_pattern pr_pat mp ++ - spc () ++ str "=>" ++ brk (1,4) ++ pr t - (* - | Pat (rl,mp,t) -> - hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl ++ - (if rl <> [] then spc () else mt ()) ++ - hov 0 (str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ - str "=>" ++ brk (1,4) ++ pr t)) - *) - | Pat (rl,mp,t) -> - hov 0 ( - hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl) ++ - (if not (List.is_empty rl) then spc () else mt ()) ++ - hov 0 ( - str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ - str "=>" ++ brk (1,4) ++ pr t)) - | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t - - let pr_funvar = function - | None -> spc () ++ str "_" - | Some id -> spc () ++ pr_id id - - let pr_let_clause k pr (id,(bl,t)) = - hov 0 (keyword k ++ spc () ++ pr_lident id ++ prlist pr_funvar bl ++ - str " :=" ++ brk (1,1) ++ pr (TacArg (Loc.ghost,t))) - - let pr_let_clauses recflag pr = function - | hd::tl -> - hv 0 - (pr_let_clause (if recflag then "let rec" else "let") pr hd ++ - prlist (fun t -> spc () ++ pr_let_clause "with" pr t) tl) - | [] -> anomaly (Pp.str "LetIn must declare at least one binding") - - let pr_seq_body pr tl = - hv 0 (str "[ " ++ - prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++ - str " ]") - - let pr_dispatch pr tl = - hv 0 (str "[>" ++ - prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++ - str " ]") - - let pr_opt_tactic pr = function - | TacId [] -> mt () - | t -> pr t - - let pr_tac_extend_gen pr tf tm tl = - prvect_with_sep mt (fun t -> pr t ++ spc () ++ str "| ") tf ++ - pr_opt_tactic pr tm ++ str ".." ++ - prvect_with_sep mt (fun t -> spc () ++ str "| " ++ pr t) tl - - let pr_then_gen pr tf tm tl = - hv 0 (str "[ " ++ - pr_tac_extend_gen pr tf tm tl ++ - str " ]") - - let pr_tac_extend pr tf tm tl = - hv 0 (str "[>" ++ - pr_tac_extend_gen pr tf tm tl ++ - str " ]") - - let pr_hintbases = function - | None -> keyword "with" ++ str" *" - | Some [] -> mt () - | Some l -> hov 2 (keyword "with" ++ prlist (fun s -> spc () ++ str s) l) - - let pr_auto_using prc = function - | [] -> mt () - | l -> hov 2 (keyword "using" ++ spc () ++ prlist_with_sep pr_comma prc l) - - let pr_then () = str ";" - - let ltop = (5,E) - let lseq = 4 - let ltactical = 3 - let lorelse = 2 - let llet = 5 - let lfun = 5 - let lcomplete = 1 - let labstract = 3 - let lmatch = 1 - let latom = 0 - let lcall = 1 - let leval = 1 - let ltatom = 1 - let linfo = 5 - - let level_of (n,p) = match p with E -> n | L -> n-1 | Prec n -> n | Any -> lseq - - (** A printer for tactics that polymorphically works on the three - "raw", "glob" and "typed" levels *) - - type 'a printer = { - pr_tactic : tolerability -> 'tacexpr -> std_ppcmds; - pr_constr : 'trm -> std_ppcmds; - pr_lconstr : 'trm -> std_ppcmds; - pr_dconstr : 'dtrm -> std_ppcmds; - pr_pattern : 'pat -> std_ppcmds; - pr_lpattern : 'pat -> std_ppcmds; - pr_constant : 'cst -> std_ppcmds; - pr_reference : 'ref -> std_ppcmds; - pr_name : 'nam -> std_ppcmds; - pr_generic : 'lev generic_argument -> std_ppcmds; - pr_extend : int -> ml_tactic_entry -> 'a gen_tactic_arg list -> std_ppcmds; - pr_alias : int -> KerName.t -> 'a gen_tactic_arg list -> std_ppcmds; - } - - constraint 'a = < - term :'trm; - dterm :'dtrm; - pattern :'pat; - constant :'cst; - reference :'ref; - name :'nam; - tacexpr :'tacexpr; - level :'lev - > - - let pr_atom pr strip_prod_binders tag_atom = - let pr_with_bindings = pr_with_bindings pr.pr_constr pr.pr_lconstr in - let pr_with_bindings_arg_full = pr_with_bindings_arg in - let pr_with_bindings_arg = pr_with_bindings_arg pr.pr_constr pr.pr_lconstr in - let pr_red_expr = pr_red_expr (pr.pr_constr,pr.pr_lconstr,pr.pr_constant,pr.pr_pattern) in - - let _pr_constrarg c = spc () ++ pr.pr_constr c in - let pr_lconstrarg c = spc () ++ pr.pr_lconstr c in - let pr_intarg n = spc () ++ int n in - - (* Some printing combinators *) - let pr_eliminator cb = keyword "using" ++ pr_arg pr_with_bindings cb in - - let pr_binder_fix (nal,t) = - (* match t with - | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal - | _ ->*) - let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr t in - spc() ++ hov 1 (str"(" ++ s ++ str")") in - - let pr_fix_tac (id,n,c) = - let rec set_nth_name avoid n = function - (nal,ty)::bll -> - if n <= List.length nal then - match List.chop (n-1) nal with - _, (_,Name id) :: _ -> id, (nal,ty)::bll - | bef, (loc,Anonymous) :: aft -> - let id = next_ident_away (Id.of_string"y") avoid in - id, ((bef@(loc,Name id)::aft, ty)::bll) - | _ -> assert false - else - let (id,bll') = set_nth_name avoid (n-List.length nal) bll in - (id,(nal,ty)::bll') - | [] -> assert false in - let (bll,ty) = strip_prod_binders n c in - let names = - List.fold_left - (fun ln (nal,_) -> List.fold_left - (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln) - ln nal) - [] bll in - let idarg,bll = set_nth_name names n bll in - let annot = match names with - | [_] -> - mt () - | _ -> - spc() ++ str"{" - ++ keyword "struct" ++ spc () - ++ pr_id idarg ++ str"}" - in - hov 1 (str"(" ++ pr_id id ++ - prlist pr_binder_fix bll ++ annot ++ str" :" ++ - pr_lconstrarg ty ++ str")") in - (* spc() ++ - hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ _pr_constrarg - c) - *) - let pr_cofix_tac (id,c) = - hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg c ++ str")") in - - (* Printing tactics as arguments *) - let rec pr_atom0 a = tag_atom a (match a with - | TacIntroPattern (false,[]) -> primitive "intros" - | TacIntroPattern (true,[]) -> primitive "eintros" - | t -> str "(" ++ pr_atom1 t ++ str ")" - ) - - (* Main tactic printer *) - and pr_atom1 a = tag_atom a (match a with - (* Basic tactics *) - | 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) - | TacApply (a,ev,cb,inhyp) -> - hov 1 ( - (if a then mt() else primitive "simple ") ++ - primitive (with_evars ev "apply") ++ spc () ++ - prlist_with_sep pr_comma pr_with_bindings_arg cb ++ - pr_non_empty_arg (pr_in_hyp_as pr.pr_dconstr pr.pr_name) inhyp - ) - | TacElim (ev,cb,cbo) -> - hov 1 ( - primitive (with_evars ev "elim") - ++ pr_arg pr_with_bindings_arg cb - ++ pr_opt pr_eliminator cbo) - | TacCase (ev,cb) -> - hov 1 (primitive (with_evars ev "case") ++ spc () ++ pr_with_bindings_arg cb) - | TacMutualFix (id,n,l) -> - hov 1 ( - primitive "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc() - ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_fix_tac l) - | TacMutualCofix (id,l) -> - hov 1 ( - primitive "cofix" ++ spc () ++ pr_id id ++ spc() - ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_cofix_tac l - ) - | TacAssert (b,Some tac,ipat,c) -> - hov 1 ( - primitive (if b then "assert" else "enough") ++ - pr_assumption pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ++ - pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac - ) - | TacAssert (_,None,ipat,c) -> - hov 1 ( - primitive "pose proof" - ++ pr_assertion pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c - ) - | TacGeneralize l -> - hov 1 ( - primitive "generalize" ++ spc () - ++ prlist_with_sep pr_comma (fun (cl,na) -> - pr_with_occurrences pr.pr_constr cl ++ pr_as_name na) - l - ) - | TacLetTac (na,c,cl,true,_) when Locusops.is_nowhere cl -> - hov 1 (primitive "pose" ++ pr_pose pr.pr_constr pr.pr_lconstr na c) - | TacLetTac (na,c,cl,b,e) -> - hov 1 ( - (if b then primitive "set" else primitive "remember") ++ - (if b then pr_pose pr.pr_constr pr.pr_lconstr na c - else pr_pose_as_style pr.pr_constr na c) ++ - pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++ - pr_non_empty_arg (pr_clauses (Some b) pr.pr_name) cl) - (* | TacInstantiate (n,c,ConclLocation ()) -> - hov 1 (str "instantiate" ++ spc() ++ - hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++ - pr_lconstrarg c ++ str ")" )) - | TacInstantiate (n,c,HypLocation (id,hloc)) -> - hov 1 (str "instantiate" ++ spc() ++ - hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++ - pr_lconstrarg c ++ str ")" ) - ++ str "in" ++ pr_hyp_location pr.pr_name (id,[],(hloc,ref None))) - *) - - (* Derived basic tactics *) - | TacInductionDestruct (isrec,ev,(l,el)) -> - hov 1 ( - primitive (with_evars ev (if isrec then "induction" else "destruct")) - ++ spc () - ++ prlist_with_sep pr_comma (fun (h,ids,cl) -> - pr_destruction_arg pr.pr_dconstr pr.pr_dconstr h ++ - pr_non_empty_arg (pr_with_induction_names pr.pr_dconstr) ids ++ - pr_opt (pr_clauses None pr.pr_name) cl) l ++ - pr_opt pr_eliminator el - ) - - (* Conversion *) - | TacReduce (r,h) -> - hov 1 ( - pr_red_expr r - ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h - ) - | TacChange (op,c,h) -> - hov 1 ( - primitive "change" ++ brk (1,1) - ++ ( - match op with - None -> - mt () - | Some p -> - pr.pr_pattern p ++ spc () - ++ keyword "with" ++ spc () - ) ++ pr.pr_dconstr c ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h - ) - - (* Equality and inversion *) - | TacRewrite (ev,l,cl,tac) -> - hov 1 ( - primitive (with_evars ev "rewrite") ++ spc () - ++ prlist_with_sep - (fun () -> str ","++spc()) - (fun (b,m,c) -> - pr_orient b ++ pr_multi m ++ - pr_with_bindings_arg_full pr.pr_dconstr pr.pr_dconstr c) - l - ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) cl - ++ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac - ) - | TacInversion (DepInversion (k,c,ids),hyp) -> - hov 1 ( - primitive "dependent " ++ pr_inversion_kind k ++ spc () - ++ pr_quantified_hypothesis hyp - ++ pr_with_inversion_names pr.pr_dconstr ids - ++ pr_with_constr pr.pr_constr c - ) - | TacInversion (NonDepInversion (k,cl,ids),hyp) -> - hov 1 ( - pr_inversion_kind k ++ spc () - ++ pr_quantified_hypothesis hyp - ++ pr_non_empty_arg (pr_with_inversion_names pr.pr_dconstr) ids - ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl - ) - | TacInversion (InversionUsing (c,cl),hyp) -> - hov 1 ( - primitive "inversion" ++ spc() - ++ pr_quantified_hypothesis hyp ++ spc () - ++ keyword "using" ++ spc () ++ pr.pr_constr c - ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl - ) - ) - in - pr_atom1 - - let make_pr_tac pr strip_prod_binders tag_atom tag = - - let extract_binders = function - | Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body) - | body -> ([],body) in - let rec pr_tac inherited tac = - let return (doc, l) = (tag tac doc, l) in - let (strm, prec) = return (match tac with - | TacAbstract (t,None) -> - keyword "abstract " ++ pr_tac (labstract,L) t, labstract - | TacAbstract (t,Some s) -> - hov 0 ( - keyword "abstract" - ++ str" (" ++ pr_tac (labstract,L) t ++ str")" ++ spc () - ++ keyword "using" ++ spc () ++ pr_id s), - labstract - | TacLetIn (recflag,llc,u) -> - let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in - v 0 - (hv 0 ( - pr_let_clauses recflag (pr_tac ltop) llc - ++ spc () ++ keyword "in" - ) ++ fnl () ++ pr_tac (llet,E) u), - llet - | TacMatch (lz,t,lrul) -> - hov 0 ( - pr_lazy lz ++ keyword "match" ++ spc () - ++ pr_tac ltop t ++ spc () ++ keyword "with" - ++ prlist (fun r -> - fnl () ++ str "| " - ++ pr_match_rule true (pr_tac ltop) pr.pr_lpattern r - ) lrul - ++ fnl() ++ keyword "end"), - lmatch - | TacMatchGoal (lz,lr,lrul) -> - hov 0 ( - pr_lazy lz - ++ keyword (if lr then "match reverse goal with" else "match goal with") - ++ prlist (fun r -> - fnl () ++ str "| " - ++ pr_match_rule false (pr_tac ltop) pr.pr_lpattern r - ) lrul ++ fnl() ++ keyword "end"), - lmatch - | TacFun (lvar,body) -> - hov 2 ( - keyword "fun" - ++ prlist pr_funvar lvar ++ str " =>" ++ spc () - ++ pr_tac (lfun,E) body), - lfun - | TacThens (t,tl) -> - hov 1 ( - pr_tac (lseq,E) t ++ pr_then () ++ spc () - ++ pr_seq_body (pr_opt_tactic (pr_tac ltop)) tl), - lseq - | TacThen (t1,t2) -> - hov 1 ( - pr_tac (lseq,E) t1 ++ pr_then () ++ spc () - ++ pr_tac (lseq,L) t2), - lseq - | TacDispatch tl -> - pr_dispatch (pr_tac ltop) tl, lseq - | TacExtendTac (tf,t,tr) -> - pr_tac_extend (pr_tac ltop) tf t tr , lseq - | TacThens3parts (t1,tf,t2,tl) -> - hov 1 ( - pr_tac (lseq,E) t1 ++ pr_then () ++ spc () - ++ pr_then_gen (pr_tac ltop) tf t2 tl), - lseq - | TacTry t -> - hov 1 ( - keyword "try" ++ spc () ++ pr_tac (ltactical,E) t), - ltactical - | TacDo (n,t) -> - hov 1 ( - str "do" ++ spc () - ++ pr_or_var int n ++ spc () - ++ pr_tac (ltactical,E) t), - ltactical - | TacTimeout (n,t) -> - hov 1 ( - keyword "timeout " - ++ pr_or_var int n ++ spc () - ++ pr_tac (ltactical,E) t), - ltactical - | TacTime (s,t) -> - hov 1 ( - keyword "time" - ++ pr_opt str s ++ spc () - ++ pr_tac (ltactical,E) t), - ltactical - | TacRepeat t -> - hov 1 ( - keyword "repeat" ++ spc () - ++ pr_tac (ltactical,E) t), - ltactical - | TacProgress t -> - hov 1 ( - keyword "progress" ++ spc () - ++ pr_tac (ltactical,E) t), - ltactical - | TacShowHyps t -> - hov 1 ( - keyword "infoH" ++ spc () - ++ pr_tac (ltactical,E) t), - ltactical - | TacInfo t -> - hov 1 ( - keyword "info" ++ spc () - ++ pr_tac (ltactical,E) t), - linfo - | TacOr (t1,t2) -> - hov 1 ( - pr_tac (lorelse,L) t1 ++ spc () - ++ str "+" ++ brk (1,1) - ++ pr_tac (lorelse,E) t2), - lorelse - | TacOnce t -> - hov 1 ( - keyword "once" ++ spc () - ++ pr_tac (ltactical,E) t), - ltactical - | TacExactlyOnce t -> - hov 1 ( - keyword "exactly_once" ++ spc () - ++ pr_tac (ltactical,E) t), - ltactical - | TacIfThenCatch (t,tt,te) -> - hov 1 ( - str"tryif" ++ spc() ++ pr_tac (ltactical,E) t ++ brk(1,1) ++ - str"then" ++ spc() ++ pr_tac (ltactical,E) tt ++ brk(1,1) ++ - str"else" ++ spc() ++ pr_tac (ltactical,E) te ++ brk(1,1)), - ltactical - | TacOrelse (t1,t2) -> - hov 1 ( - pr_tac (lorelse,L) t1 ++ spc () - ++ str "||" ++ brk (1,1) - ++ pr_tac (lorelse,E) t2), - lorelse - | TacFail (g,n,l) -> - let arg = - match n with - | ArgArg 0 -> mt () - | _ -> pr_arg (pr_or_var int) n - in - let name = - match g with - | TacGlobal -> keyword "gfail" - | TacLocal -> keyword "fail" - in - hov 1 ( - name ++ arg - ++ prlist (pr_arg (pr_message_token pr.pr_name)) l), - latom - | TacFirst tl -> - keyword "first" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet - | TacSolve tl -> - keyword "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet - | TacComplete t -> - pr_tac (lcomplete,E) t, lcomplete - | TacSelect (s, tac) -> pr_goal_selector s ++ spc () ++ pr_tac ltop tac, latom - | TacId l -> - keyword "idtac" ++ prlist (pr_arg (pr_message_token pr.pr_name)) l, latom - | TacAtom (loc,t) -> - pr_with_comments loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom - | TacArg(_,Tacexp e) -> - pr.pr_tactic (latom,E) e, latom - | TacArg(_,ConstrMayEval (ConstrTerm c)) -> - keyword "constr:" ++ pr.pr_constr c, latom - | TacArg(_,ConstrMayEval c) -> - pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval - | TacArg(_,TacFreshId l) -> - primitive "fresh" ++ pr_fresh_ids l, latom - | TacArg(_,TacGeneric arg) -> - pr.pr_generic arg, latom - | TacArg(_,TacCall(loc,f,[])) -> - pr.pr_reference f, latom - | TacArg(_,TacCall(loc,f,l)) -> - pr_with_comments loc (hov 1 ( - pr.pr_reference f ++ spc () - ++ prlist_with_sep spc pr_tacarg l)), - lcall - | TacArg (_,a) -> - pr_tacarg a, latom - | TacML (loc,s,l) -> - pr_with_comments loc (pr.pr_extend 1 s l), lcall - | TacAlias (loc,kn,l) -> - pr_with_comments loc (pr.pr_alias (level_of inherited) kn l), latom - ) - in - if prec_less prec inherited then strm - else str"(" ++ strm ++ str")" - - and pr_tacarg = function - | Reference r -> - pr.pr_reference r - | ConstrMayEval c -> - pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c - | TacFreshId l -> - keyword "fresh" ++ pr_fresh_ids l - | TacPretype c -> - keyword "type_term" ++ pr.pr_constr c - | TacNumgoals -> - keyword "numgoals" - | (TacCall _|Tacexp _ | TacGeneric _) as a -> - hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (Loc.ghost,a)))) - - in pr_tac - - let strip_prod_binders_glob_constr n (ty,_) = - let rec strip_ty acc n ty = - if Int.equal n 0 then (List.rev acc, (ty,None)) else - match ty with - Glob_term.GProd(loc,na,Explicit,a,b) -> - strip_ty (([Loc.ghost,na],(a,None))::acc) (n-1) b - | _ -> error "Cannot translate fix tactic: not enough products" in - strip_ty [] n ty - - let raw_printers = - (strip_prod_binders_expr) - - let rec pr_raw_tactic_level n (t:raw_tactic_expr) = - let pr = { - pr_tactic = pr_raw_tactic_level; - pr_constr = pr_constr_expr; - pr_dconstr = pr_constr_expr; - pr_lconstr = pr_lconstr_expr; - pr_pattern = pr_constr_pattern_expr; - pr_lpattern = pr_lconstr_pattern_expr; - pr_constant = pr_or_by_notation pr_reference; - pr_reference = pr_reference; - pr_name = pr_lident; - pr_generic = (fun arg -> Pputils.pr_raw_generic (Global.env ()) arg); - pr_extend = pr_raw_extend_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; - pr_alias = pr_raw_alias pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; - } in - make_pr_tac - pr raw_printers - tag_raw_atomic_tactic_expr tag_raw_tactic_expr - n t - - let pr_raw_tactic = pr_raw_tactic_level ltop - - let pr_and_constr_expr pr (c,_) = pr c - - let pr_pat_and_constr_expr pr (_,(c,_),_) = pr c - - let pr_glob_tactic_level env n t = - let glob_printers = - (strip_prod_binders_glob_constr) - in - let rec prtac n (t:glob_tactic_expr) = - let pr = { - pr_tactic = prtac; - pr_constr = pr_and_constr_expr (pr_glob_constr_env env); - pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); - pr_lconstr = pr_and_constr_expr (pr_lglob_constr_env env); - pr_pattern = pr_pat_and_constr_expr (pr_glob_constr_env env); - pr_lpattern = pr_pat_and_constr_expr (pr_lglob_constr_env env); - pr_constant = pr_or_var (pr_and_short_name (pr_evaluable_reference_env env)); - pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant); - pr_name = pr_lident; - pr_generic = (fun arg -> Pputils.pr_glb_generic (Global.env ()) arg); - pr_extend = pr_glob_extend_rec - (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) - prtac (pr_pat_and_constr_expr (pr_glob_constr_env env)); - pr_alias = pr_glob_alias - (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) - prtac (pr_pat_and_constr_expr (pr_glob_constr_env env)); - } in - make_pr_tac - pr glob_printers - tag_glob_atomic_tactic_expr tag_glob_tactic_expr - n t - in - prtac n t - - let pr_glob_tactic env = pr_glob_tactic_level env ltop - - let strip_prod_binders_constr n ty = - let rec strip_ty acc n ty = - if n=0 then (List.rev acc, ty) else - match Term.kind_of_term ty with - Term.Prod(na,a,b) -> - strip_ty (([Loc.ghost,na],a)::acc) (n-1) b - | _ -> error "Cannot translate fix tactic: not enough products" in - strip_ty [] n ty - - let pr_atomic_tactic_level env n t = - let prtac n (t:atomic_tactic_expr) = - let pr = { - pr_tactic = (fun _ _ -> str ""); - pr_constr = pr_constr_env env Evd.empty; - pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); - pr_lconstr = pr_lconstr_env env Evd.empty; - pr_pattern = pr_constr_pattern_env env Evd.empty; - pr_lpattern = pr_lconstr_pattern_env env Evd.empty; - pr_constant = pr_evaluable_reference_env env; - pr_reference = pr_located pr_ltac_constant; - pr_name = pr_id; - (** Those are not used by the atomic printer *) - pr_generic = (fun _ -> assert false); - pr_extend = (fun _ _ _ -> assert false); - pr_alias = (fun _ _ _ -> assert false); - } - in - pr_atom pr strip_prod_binders_constr tag_atomic_tactic_expr t - in - prtac n t - - let pr_raw_generic = Pputils.pr_raw_generic - - let pr_glb_generic = Pputils.pr_glb_generic - - let pr_raw_extend env = pr_raw_extend_rec - pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr - - let pr_glob_extend env = pr_glob_extend_rec - (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) - (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env)) - - let pr_alias pr lev key args = - pr_alias_gen (fun _ arg -> pr arg) lev key args - - let pr_extend pr lev ml args = - pr_extend_gen pr lev ml args - - let pr_atomic_tactic env = pr_atomic_tactic_level env ltop - -end - -module Tag = -struct - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["tactic"; "keyword"] - - let primitive = - let style = Terminal.make ~fg_color:`LIGHT_GREEN () in - Ppstyle.make ~style ["tactic"; "primitive"] - - let string = - let style = Terminal.make ~fg_color:`LIGHT_RED () in - Ppstyle.make ~style ["tactic"; "string"] - -end - -include Make (Ppconstr) (struct - let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s - let do_not_tag _ x = x - let tag_keyword = tag Tag.keyword - let tag_primitive = tag Tag.primitive - let tag_string = tag Tag.string - let tag_glob_tactic_expr = do_not_tag - let tag_glob_atomic_tactic_expr = do_not_tag - let tag_raw_tactic_expr = do_not_tag - let tag_raw_atomic_tactic_expr = do_not_tag - let tag_atomic_tactic_expr = do_not_tag -end) - -let declare_extra_genarg_pprule wit - (f : 'a raw_extra_genarg_printer) - (g : 'b glob_extra_genarg_printer) - (h : 'c extra_genarg_printer) = - begin match wit with - | ExtraArg s -> () - | _ -> error "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 g x = - 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 - in - let h x = - let env = Global.env () in - h (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) (fun _ _ -> str "") x - in - Genprint.register_print0 wit f g h - -(** Registering *) - -let run_delayed c = - Sigma.run Evd.empty { Sigma.run = fun sigma -> c.delayed (Global.env ()) sigma } - -let run_delayed_destruction_arg = function (* HH: Using Evd.empty looks suspicious *) - | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (fst (run_delayed g)) - | clear_flag,ElimOnAnonHyp n as x -> x - | clear_flag,ElimOnIdent id as x -> x - -let () = - let pr_bool b = if b then str "true" else str "false" in - let pr_unit _ = str "()" in - let pr_string s = str "\"" ++ str s ++ str "\"" in - Genprint.register_print0 wit_int_or_var - (pr_or_var int) (pr_or_var int) int; - Genprint.register_print0 wit_ref - pr_reference (pr_or_var (pr_located pr_global)) pr_global; - Genprint.register_print0 wit_ident - pr_id pr_id pr_id; - Genprint.register_print0 wit_var - (pr_located pr_id) (pr_located pr_id) pr_id; - Genprint.register_print0 - wit_intro_pattern - (Miscprint.pr_intro_pattern pr_constr_expr) - (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr c)) - (Miscprint.pr_intro_pattern (fun c -> pr_constr (fst (run_delayed c)))); - Genprint.register_print0 - wit_clause_dft_concl - (pr_clauses (Some true) pr_lident) - (pr_clauses (Some true) pr_lident) - (pr_clauses (Some true) (fun id -> pr_lident (Loc.ghost,id))) - ; - Genprint.register_print0 - wit_constr - Ppconstr.pr_constr_expr - (fun (c, _) -> Printer.pr_glob_constr c) - Printer.pr_constr - ; - Genprint.register_print0 - wit_uconstr - Ppconstr.pr_constr_expr - (fun (c,_) -> Printer.pr_glob_constr c) - Printer.pr_closed_glob - ; - Genprint.register_print0 - wit_open_constr - Ppconstr.pr_constr_expr - (fun (c, _) -> Printer.pr_glob_constr c) - Printer.pr_constr - ; - 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, pr_and_constr_expr pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr)) - (pr_red_expr (pr_constr, pr_lconstr, pr_evaluable_reference, pr_constr_pattern)); - Genprint.register_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; - Genprint.register_print0 wit_bindings - (pr_bindings_no_with pr_constr_expr pr_lconstr_expr) - (pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) - (fun it -> pr_bindings_no_with pr_constr pr_lconstr (fst (run_delayed it))); - 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) (pr_and_constr_expr pr_lglob_constr)) - (fun it -> pr_with_bindings pr_constr pr_lconstr (fst (run_delayed it))); - 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) (pr_and_constr_expr pr_lglob_constr)) - (fun it -> pr_destruction_arg pr_constr pr_lconstr (run_delayed_destruction_arg it)); - Genprint.register_print0 Stdarg.wit_int int int int; - Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool pr_bool; - Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit pr_unit; - Genprint.register_print0 Stdarg.wit_pre_ident str str str; - Genprint.register_print0 Stdarg.wit_string pr_string pr_string pr_string - -let () = - let printer _ _ prtac = prtac (0, E) in - declare_extra_genarg_pprule wit_tactic printer printer printer - -let () = - let pr_unit _ _ _ () = str "()" in - let printer _ _ prtac = prtac (0, E) in - declare_extra_genarg_pprule wit_ltac printer printer pr_unit - -module Richpp = struct - - include Make (Ppconstr.Richpp) (struct - open Ppannotation - open Genarg - let do_not_tag _ x = x - let tag e s = Pp.tag (Pp.Tag.inj e tag) s - let tag_keyword = tag AKeyword - let tag_primitive = tag AKeyword - let tag_string = do_not_tag () - let tag_glob_tactic_expr e = tag (AGlbGenArg (in_gen (glbwit wit_ltac) e)) - let tag_glob_atomic_tactic_expr = do_not_tag - let tag_raw_tactic_expr e = tag (ARawGenArg (in_gen (rawwit wit_ltac) e)) - let tag_raw_atomic_tactic_expr = do_not_tag - let tag_atomic_tactic_expr = do_not_tag - end) - -end diff --git a/ltac/pptactic.mli b/ltac/pptactic.mli deleted file mode 100644 index 86e3ea548..000000000 --- a/ltac/pptactic.mli +++ /dev/null @@ -1,67 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - (tolerability -> raw_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds - -type 'a glob_extra_genarg_printer = - (glob_constr_and_expr -> std_ppcmds) -> - (glob_constr_and_expr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds - -type 'a extra_genarg_printer = - (Term.constr -> std_ppcmds) -> - (Term.constr -> std_ppcmds) -> - (tolerability -> Val.t -> std_ppcmds) -> - 'a -> std_ppcmds - -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 - -type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list - -type pp_tactic = { - pptac_level : int; - pptac_prods : grammar_terminals; -} - -val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit - -(** The default pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as raw strings. *) -include Pptacticsig.Pp - -(** The rich pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as annotated strings. The annotations can be - retrieved using {!RichPp.rich_pp}. Their definitions are - located in {!Ppannotation.t}. *) -module Richpp : Pptacticsig.Pp - -val ltop : tolerability diff --git a/ltac/pptacticsig.mli b/ltac/pptacticsig.mli deleted file mode 100644 index 74ddd377a..000000000 --- a/ltac/pptacticsig.mli +++ /dev/null @@ -1,81 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds - val pr_red_expr : - ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> - ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds - val pr_may_eval : - ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> - ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds - - val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds - - val pr_in_clause : - ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds - - val pr_clauses : bool option -> - ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds - - val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds - - val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds - - val pr_raw_extend: env -> int -> - ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds - - val pr_glob_extend: env -> int -> - ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds - - val pr_extend : - (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds - - val pr_alias_key : Names.KerName.t -> std_ppcmds - - val pr_alias : (Val.t -> std_ppcmds) -> - int -> Names.KerName.t -> Val.t list -> std_ppcmds - - val pr_alias_key : Names.KerName.t -> std_ppcmds - - val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds - - val pr_raw_tactic : raw_tactic_expr -> std_ppcmds - - val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds - - val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds - - val pr_atomic_tactic : env -> atomic_tactic_expr -> std_ppcmds - - val pr_hintbases : string list option -> std_ppcmds - - val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds - - val pr_bindings : - ('constr -> std_ppcmds) -> - ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds - - val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds - - val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> - ('b, 'a) match_rule -> std_ppcmds - - val pr_value : tolerability -> Val.t -> std_ppcmds - -end diff --git a/ltac/profile_ltac.ml b/ltac/profile_ltac.ml deleted file mode 100644 index 2514ededb..000000000 --- a/ltac/profile_ltac.ml +++ /dev/null @@ -1,420 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* strbrk "Ltac Profiler cannot yet handle backtracking \ - into multi-success tactics; profiling results may be wildly inaccurate.") - -let warn_encountered_multi_success_backtracking () = - if !encountered_multi_success_backtracking then - warn_profile_backtracking () - -let encounter_multi_success_backtracking () = - if not !encountered_multi_success_backtracking - then begin - encountered_multi_success_backtracking := true; - warn_encountered_multi_success_backtracking () - end - - -(* *************** tree data structure for profiling ****************** *) - -type treenode = { - name : M.key; - total : float; - local : float; - ncalls : int; - max_total : float; - children : treenode M.t -} - -let empty_treenode name = { - name; - total = 0.0; - local = 0.0; - ncalls = 0; - max_total = 0.0; - children = M.empty; -} - -let root = "root" - -module Local = Summary.Local - -let stack = Local.ref ~name:"LtacProf-stack" [empty_treenode root] - -let reset_profile_tmp () = - Local.(stack := [empty_treenode root]); - encountered_multi_success_backtracking := false - -(* ************** XML Serialization ********************* *) - -let rec of_ltacprof_tactic (name, t) = - assert (String.equal name t.name); - let open Xml_datatype in - let total = string_of_float t.total in - let local = string_of_float t.local in - let ncalls = string_of_int t.ncalls in - let max_total = string_of_float t.max_total in - let children = List.map of_ltacprof_tactic (M.bindings t.children) in - Element ("ltacprof_tactic", - [ ("name", name); ("total",total); ("local",local); - ("ncalls",ncalls); ("max_total",max_total)], - children) - -let of_ltacprof_results t = - let open Xml_datatype in - assert(String.equal t.name root); - let children = List.map of_ltacprof_tactic (M.bindings t.children) in - Element ("ltacprof", [("total_time", string_of_float t.total)], children) - -let rec to_ltacprof_tactic m xml = - let open Xml_datatype in - match xml with - | Element ("ltacprof_tactic", - [("name", name); ("total",total); ("local",local); - ("ncalls",ncalls); ("max_total",max_total)], xs) -> - let node = { - name; - total = float_of_string total; - local = float_of_string local; - ncalls = int_of_string ncalls; - max_total = float_of_string max_total; - children = List.fold_left to_ltacprof_tactic M.empty xs; - } in - M.add name node m - | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof_tactic XML") - -let to_ltacprof_results xml = - let open Xml_datatype in - match xml with - | Element ("ltacprof", [("total_time", t)], xs) -> - { name = root; - total = float_of_string t; - ncalls = 0; - max_total = 0.0; - local = 0.0; - children = List.fold_left to_ltacprof_tactic M.empty xs } - | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof XML") - -let feedback_results results = - Feedback.(feedback - (Custom (Loc.dummy_loc, "ltacprof_results", of_ltacprof_results results))) - -(* ************** pretty printing ************************************* *) - -let format_sec x = (Printf.sprintf "%.3fs" x) -let format_ratio x = (Printf.sprintf "%.1f%%" (100. *. x)) -let padl n s = ws (max 0 (n - utf8_length s)) ++ str s -let padr n s = str s ++ ws (max 0 (n - utf8_length s)) -let padr_with c n s = - let ulength = utf8_length s in - str (utf8_sub s 0 n) ++ str (String.make (max 0 (n - ulength)) c) - -let rec list_iter_is_last f = function - | [] -> [] - | [x] -> [f true x] - | x :: xs -> f false x :: list_iter_is_last f xs - -let header = - str " tactic local total calls max " ++ - fnl () ++ - str "────────────────────────────────────────┴──────┴──────┴───────┴─────────┘" ++ - fnl () - -let rec print_node ~filter all_total indent prefix (s, e) = - h 0 ( - padr_with '-' 40 (prefix ^ s ^ " ") - ++ padl 7 (format_ratio (e.local /. all_total)) - ++ padl 7 (format_ratio (e.total /. all_total)) - ++ padl 8 (string_of_int e.ncalls) - ++ padl 10 (format_sec (e.max_total)) - ) ++ - fnl () ++ - print_table ~filter all_total indent false e.children - -and print_table ~filter all_total indent first_level table = - let fold _ n l = - let s, total = n.name, n.total in - if filter s total then (s, n) :: l else l in - let ls = M.fold fold table [] in - match ls with - | [s, n] when not first_level -> - v 0 (print_node ~filter all_total indent (indent ^ "└") (s, n)) - | _ -> - let ls = - List.sort (fun (_, { total = s1 }) (_, { total = s2}) -> - compare s2 s1) ls in - let iter is_last = - let sep0 = if first_level then "" else if is_last then " " else " │" in - let sep1 = if first_level then "─" else if is_last then " └─" else " ├─" in - print_node ~filter all_total (indent ^ sep0) (indent ^ sep1) - in - prlist (fun pr -> pr) (list_iter_is_last iter ls) - -let to_string ~filter ?(cutoff=0.0) node = - let tree = node.children in - let all_total = M.fold (fun _ { total } a -> total +. a) node.children 0.0 in - let flat_tree = - let global = ref M.empty in - let find_tactic tname l = - try M.find tname !global - with Not_found -> - let e = empty_treenode tname in - global := M.add tname e !global; - e in - let add_tactic tname stats = global := M.add tname stats !global in - let sum_stats add_total - { name; total = t1; local = l1; ncalls = n1; max_total = m1 } - { total = t2; local = l2; ncalls = n2; max_total = m2 } = { - name; - total = if add_total then t1 +. t2 else t1; - local = l1 +. l2; - ncalls = n1 + n2; - max_total = if add_total then max m1 m2 else m1; - children = M.empty; - } in - let rec cumulate table = - let iter _ ({ name; children } as statistics) = - if filter name then begin - let stats' = find_tactic name global in - add_tactic name (sum_stats true stats' statistics); - end; - cumulate children - in - M.iter iter table - in - cumulate tree; - !global - in - warn_encountered_multi_success_backtracking (); - let filter s n = filter s && (all_total <= 0.0 || n /. all_total >= cutoff /. 100.0) in - let msg = - h 0 (str "total time: " ++ padl 11 (format_sec (all_total))) ++ - fnl () ++ - fnl () ++ - header ++ - print_table ~filter all_total "" true flat_tree ++ - fnl () ++ - header ++ - print_table ~filter all_total "" true tree - in - msg - -(* ******************** profiling code ************************************** *) - -let get_child name node = - try M.find name node.children - with Not_found -> empty_treenode name - -let time () = - let times = Unix.times () in - times.Unix.tms_utime +. times.Unix.tms_stime - -let string_of_call ck = - let s = - string_of_ppcmds - (match ck with - | Tacexpr.LtacNotationCall s -> Pptactic.pr_alias_key s - | Tacexpr.LtacNameCall cst -> Pptactic.pr_ltac_constant cst - | Tacexpr.LtacVarCall (id, t) -> Nameops.pr_id id - | Tacexpr.LtacAtomCall te -> - (Pptactic.pr_glob_tactic (Global.env ()) - (Tacexpr.TacAtom (Loc.ghost, te))) - | Tacexpr.LtacConstrInterp (c, _) -> - pr_glob_constr_env (Global.env ()) c - | Tacexpr.LtacMLCall te -> - (Pptactic.pr_glob_tactic (Global.env ()) - te) - ) in - for i = 0 to String.length s - 1 do if s.[i] = '\n' then s.[i] <- ' ' done; - let s = try String.sub s 0 (CString.string_index_from s 0 "(*") with Not_found -> s in - CString.strip s - -let rec merge_sub_tree name tree acc = - try - let t = M.find name acc in - let t = { - name; - total = t.total +. tree.total; - ncalls = t.ncalls + tree.ncalls; - local = t.local +. tree.local; - max_total = max t.max_total tree.max_total; - children = M.fold merge_sub_tree tree.children t.children; - } in - M.add name t acc - with Not_found -> M.add name tree acc - -let merge_roots ?(disjoint=true) t1 t2 = - assert(String.equal t1.name t2.name); - { name = t1.name; - ncalls = t1.ncalls + t2.ncalls; - local = if disjoint then t1.local +. t2.local else t1.local; - total = if disjoint then t1.total +. t2.total else t1.total; - max_total = if disjoint then max t1.max_total t2.max_total else t1.max_total; - children = - M.fold merge_sub_tree t2.children t1.children } - -let rec find_in_stack what acc = function - | [] -> None - | { 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 diff = time () -. start_time in - match Local.(!stack) with - | [] | [_] -> - (* oops, our stack is invalid *) - encounter_multi_success_backtracking (); - reset_profile_tmp () - | node :: (parent :: rest as full_stack) -> - let name = string_of_call c in - if not (String.equal name node.name) then - (* oops, our stack is invalid *) - encounter_multi_success_backtracking (); - let node = { node with - total = node.total +. diff; - local = node.local +. diff; - ncalls = node.ncalls + 1; - max_total = max node.max_total diff; - } in - (* updating the stack *) - let parent = - match find_in_stack node.name [] full_stack with - | None -> - (* no rec-call, we graft the subtree *) - let parent = { parent with - local = parent.local -. diff; - children = M.add node.name node parent.children } in - Local.(stack := parent :: rest); - parent - | Some(to_update, self, rest) -> - (* we coalesce the rec-call and update the lower stack *) - let self = merge_roots ~disjoint:false self node in - let updated_stack = - List.fold_left (fun s x -> - (try M.find x.name (List.hd s).children - with Not_found -> x) :: s) (self :: rest) to_update in - Local.(stack := updated_stack); - List.hd Local.(!stack) - in - (* Calls are over, we reset the stack and send back data *) - if rest == [] && get_profiling () then begin - assert(String.equal root parent.name); - reset_profile_tmp (); - feedback_results parent - end - -let tclFINALLY tac (finally : unit Proofview.tactic) = - let open Proofview.Notations in - Proofview.tclIFCATCH - tac - (fun v -> finally <*> Proofview.tclUNIT v) - (fun (exn, info) -> finally <*> Proofview.tclZERO ~info exn) - -let do_profile s call_trace tac = - let open Proofview.Notations in - Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> - if !is_profiling then - match call_trace, Local.(!stack) with - | (_, c) :: _, parent :: rest -> - let name = string_of_call c in - let node = get_child name parent in - Local.(stack := node :: parent :: rest); - Some (time ()) - | _ :: _, [] -> assert false - | _ -> None - else None)) >>= function - | Some start_time -> - tclFINALLY - tac - (Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> - (match call_trace with - | (_, c) :: _ -> exit_tactic start_time c - | [] -> ())))) - | None -> tac - -(* ************** Accumulation of data from workers ************************* *) - -let get_local_profiling_results () = List.hd Local.(!stack) - -module SM = Map.Make(Stateid.Self) - -let data = ref SM.empty - -let _ = - Feedback.(add_feeder (function - | { id = State s; contents = Custom (_, "ltacprof_results", xml) } -> - let results = to_ltacprof_results xml in - let other_results = (* Multi success can cause this *) - try SM.find s !data - with Not_found -> empty_treenode root in - data := SM.add s (merge_roots results other_results) !data - | _ -> ())) - -let reset_profile () = - reset_profile_tmp (); - data := SM.empty - -(* ******************** *) - -let print_results_filter ~cutoff ~filter = - let valid id _ = Stm.state_of_id id <> `Expired in - data := SM.filter valid !data; - 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) -;; - -let print_results ~cutoff = - print_results_filter ~cutoff ~filter:(fun _ -> true) - -let print_results_tactic tactic = - print_results_filter ~cutoff:!Flags.profile_ltac_cutoff ~filter:(fun s -> - String.(equal tactic (sub (s ^ ".") 0 (min (1+length s) (length tactic))))) - -let do_print_results_at_close () = - if get_profiling () then print_results ~cutoff:!Flags.profile_ltac_cutoff - -let _ = Declaremods.append_end_library_hook do_print_results_at_close - -let _ = - let open Goptions in - declare_bool_option - { optsync = true; - optdepr = false; - optname = "Ltac Profiling"; - optkey = ["Ltac"; "Profiling"]; - optread = get_profiling; - optwrite = set_profiling } diff --git a/ltac/profile_ltac.mli b/ltac/profile_ltac.mli deleted file mode 100644 index e5e2e4197..000000000 --- a/ltac/profile_ltac.mli +++ /dev/null @@ -1,48 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ('a * Tacexpr.ltac_call_kind) list -> - 'b Proofview.tactic -> 'b Proofview.tactic - -val set_profiling : bool -> unit - -(* Cut off results < than specified cutoff *) -val print_results : cutoff:float -> unit - -val print_results_tactic : string -> unit - -val reset_profile : unit -> unit - -val do_print_results_at_close : unit -> unit - -(* The collected statistics for a tactic. The timing data is collected over all - * instances of a given tactic from its parent. E.g. if tactic 'aaa' calls - * 'foo' twice, then 'aaa' will contain just one entry for 'foo' with the - * statistics of the two invocations combined, and also combined over all - * invocations of 'aaa'. - * total: time spent running this tactic and its subtactics (seconds) - * local: time spent running this tactic, minus its subtactics (seconds) - * ncalls: the number of invocations of this tactic that have been made - * max_total: the greatest running time of a single invocation (seconds) - *) -type treenode = { - name : CString.Map.key; - total : float; - local : float; - ncalls : int; - max_total : float; - children : treenode CString.Map.t -} - -(* Returns the profiling results known by the current process *) -val get_local_profiling_results : unit -> treenode -val feedback_results : treenode -> unit - diff --git a/ltac/profile_ltac_tactics.ml4 b/ltac/profile_ltac_tactics.ml4 deleted file mode 100644 index 8cb76d81c..000000000 --- a/ltac/profile_ltac_tactics.ml4 +++ /dev/null @@ -1,40 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* set_profiling b)) - -TACTIC EXTEND start_ltac_profiling -| [ "start" "ltac" "profiling" ] -> [ tclSET_PROFILING true ] -END - -TACTIC EXTEND stop_profiling -| [ "stop" "ltac" "profiling" ] -> [ tclSET_PROFILING false ] -END - -VERNAC COMMAND EXTEND ResetLtacProfiling CLASSIFIED AS SIDEFF - [ "Reset" "Ltac" "Profile" ] -> [ reset_profile() ] -END - -VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY -| [ "Show" "Ltac" "Profile" ] -> [ print_results ~cutoff:!Flags.profile_ltac_cutoff ] -| [ "Show" "Ltac" "Profile" "CutOff" int(n) ] -> [ print_results ~cutoff:(float_of_int n) ] -END - -VERNAC COMMAND EXTEND ShowLtacProfileTactic CLASSIFIED AS QUERY - [ "Show" "Ltac" "Profile" string(s) ] -> [ print_results_tactic s ] -END diff --git a/ltac/rewrite.ml b/ltac/rewrite.ml deleted file mode 100644 index 3c5a109c0..000000000 --- a/ltac/rewrite.ml +++ /dev/null @@ -1,2223 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - anomaly (str "Global reference " ++ str s ++ str " not found in generalized rewriting") - -let find_reference dir s = - let gr = lazy (try_find_global_reference dir s) in - fun () -> Lazy.force gr - -type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) - -let find_global dir s = - let gr = lazy (try_find_global_reference dir s) in - fun (evd,cstrs) -> - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force gr) in - let evd = Sigma.to_evar_map sigma in - (evd, cstrs), c - -(** Utility for dealing with polymorphic applications *) - -(** Global constants. *) - -let coq_eq_ref = find_reference ["Init"; "Logic"] "eq" -let coq_eq = find_global ["Init"; "Logic"] "eq" -let coq_f_equal = find_global ["Init"; "Logic"] "f_equal" -let coq_all = find_global ["Init"; "Logic"] "all" -let impl = find_global ["Program"; "Basics"] "impl" - -(** Bookkeeping which evars are constraints so that we can - remove them at the end of the tactic. *) - -let goalevars evars = fst evars -let cstrevars evars = snd evars - -let new_cstr_evar (evd,cstrs) env t = - let s = Typeclasses.set_resolvable Evd.Store.empty false in - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (t, evd', _) = Evarutil.new_evar ~store:s env evd t in - let evd' = Sigma.to_evar_map evd' in - let ev, _ = destEvar t in - (evd', Evar.Set.add ev cstrs), t - -(** Building or looking up instances. *) -let e_new_cstr_evar env evars t = - let evd', t = new_cstr_evar !evars env t in evars := evd'; t - -(** Building or looking up instances. *) - -let extends_undefined evars evars' = - let f ev evi found = found || not (Evd.mem evars ev) - in fold_undefined f evars' false - -let app_poly_check env evars f args = - let (evars, cstrs), fc = f evars in - let evdref = ref evars in - let t = Typing.e_solve_evars env evdref (mkApp (fc, args)) in - (!evdref, cstrs), t - -let app_poly_nocheck env evars f args = - let evars, fc = f evars in - evars, mkApp (fc, args) - -let app_poly_sort b = - if b then app_poly_nocheck - else app_poly_check - -let find_class_proof proof_type proof_method env evars carrier relation = - try - let evars, goal = app_poly_check env evars proof_type [| carrier ; relation |] in - let evars', c = Typeclasses.resolve_one_typeclass env (goalevars evars) goal in - if extends_undefined (goalevars evars) evars' then raise Not_found - else app_poly_check env (evars',cstrevars evars) proof_method [| carrier; relation; c |] - with e when Logic.catchable_exception e -> raise Not_found - -(** Utility functions *) - -module GlobalBindings (M : sig - val relation_classes : string list - val morphisms : string list - val relation : string list * string - val app_poly : env -> evars -> (evars -> evars * constr) -> constr array -> evars * constr - val arrow : evars -> evars * constr -end) = struct - open M - open Context.Rel.Declaration - let relation : evars -> evars * constr = find_global (fst relation) (snd relation) - - let reflexive_type = find_global relation_classes "Reflexive" - let reflexive_proof = find_global relation_classes "reflexivity" - - let symmetric_type = find_global relation_classes "Symmetric" - let symmetric_proof = find_global relation_classes "symmetry" - - let transitive_type = find_global relation_classes "Transitive" - let transitive_proof = find_global relation_classes "transitivity" - - let forall_relation = find_global morphisms "forall_relation" - let pointwise_relation = find_global morphisms "pointwise_relation" - - let forall_relation_ref = find_reference morphisms "forall_relation" - let pointwise_relation_ref = find_reference morphisms "pointwise_relation" - - let respectful = find_global morphisms "respectful" - let respectful_ref = find_reference morphisms "respectful" - - let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation" - - let coq_forall = find_global morphisms "forall_def" - - let subrelation = find_global relation_classes "subrelation" - let do_subrelation = find_global morphisms "do_subrelation" - let apply_subrelation = find_global morphisms "apply_subrelation" - - let rewrite_relation_class = find_global relation_classes "RewriteRelation" - - let proper_class = lazy (class_info (try_find_global_reference morphisms "Proper")) - let proper_proxy_class = lazy (class_info (try_find_global_reference morphisms "ProperProxy")) - - let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) - - let proper_type = - let l = lazy (Lazy.force proper_class).cl_impl in - fun (evd,cstrs) -> - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in - let evd = Sigma.to_evar_map sigma in - (evd, cstrs), c - - let proper_proxy_type = - let l = lazy (Lazy.force proper_proxy_class).cl_impl in - fun (evd,cstrs) -> - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in - let evd = Sigma.to_evar_map sigma in - (evd, cstrs), c - - let proper_proof env evars carrier relation x = - let evars, goal = app_poly env evars proper_proxy_type [| carrier ; relation; x |] in - new_cstr_evar evars env goal - - let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env - let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env - let get_transitive_proof env = find_class_proof transitive_type transitive_proof env - - let mk_relation env evd a = - app_poly env evd relation [| a |] - - (** Build an infered signature from constraints on the arguments and expected output - relation *) - - let build_signature evars env m (cstrs : (types * types option) option list) - (finalcstr : (types * types option) option) = - let mk_relty evars newenv ty obj = - match obj with - | None | Some (_, None) -> - let evars, relty = mk_relation env evars ty in - if closed0 ty then - let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in - new_cstr_evar evars env' relty - else new_cstr_evar evars newenv relty - | Some (x, Some rel) -> evars, rel - in - let rec aux env evars ty l = - let t = Reductionops.whd_all env (goalevars evars) ty in - match kind_of_term t, l with - | Prod (na, ty, b), obj :: cstrs -> - let b = Reductionops.nf_betaiota (goalevars evars) b in - if noccurn 1 b (* non-dependent product *) then - let ty = Reductionops.nf_betaiota (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 - evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs - else - let (evars, b, arg, cstrs) = - aux (Environ.push_rel (LocalAssum (na, ty)) env) evars b cstrs - in - let ty = Reductionops.nf_betaiota (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 - if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs - else error "build_signature: no constraint can apply on a dependent argument" - | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products") - | _, [] -> - (match finalcstr with - | None | Some (_, None) -> - let t = Reductionops.nf_betaiota (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]) - in aux env evars m cstrs - - (** Folding/unfolding of the tactic constants. *) - - let unfold_impl t = - match kind_of_term t with - | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> - mkProd (Anonymous, a, lift 1 b) - | _ -> assert false - - let unfold_all t = - match kind_of_term t with - | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> - (match kind_of_term b with - | Lambda (n, ty, b) -> mkProd (n, ty, b) - | _ -> assert false) - | _ -> assert false - - let unfold_forall t = - match kind_of_term t with - | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> - (match kind_of_term b with - | Lambda (n, ty, b) -> mkProd (n, ty, b) - | _ -> assert false) - | _ -> assert false - - let arrow_morphism env evd ta tb a b = - let ap = is_Prop ta and bp = is_Prop tb in - if ap && bp then app_poly env evd impl [| a; b |], unfold_impl - else if ap then (* Domain in Prop, CoDomain in Type *) - (app_poly env evd arrow [| a; b |]), unfold_impl - (* (evd, mkProd (Anonymous, a, b)), (fun x -> x) *) - else if bp then (* Dummy forall *) - (app_poly env evd coq_all [| a; mkLambda (Anonymous, a, lift 1 b) |]), unfold_forall - else (* None in Prop, use arrow *) - (app_poly env evd arrow [| a; b |]), unfold_impl - - let rec decomp_pointwise n c = - if Int.equal n 0 then c - else - match kind_of_term c with - | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f -> - decomp_pointwise (pred n) relb - | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f -> - decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1])) - | _ -> invalid_arg "decomp_pointwise" - - let rec apply_pointwise rel = function - | arg :: args -> - (match kind_of_term rel with - | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f -> - apply_pointwise relb args - | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f -> - apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args - | _ -> invalid_arg "apply_pointwise") - | [] -> rel - - let pointwise_or_dep_relation env evd n t car rel = - if noccurn 1 car && noccurn 1 rel then - app_poly env evd pointwise_relation [| t; lift (-1) car; lift (-1) rel |] - else - app_poly env evd forall_relation - [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |] - - let lift_cstr env evars (args : constr list) c ty cstr = - let start evars env car = - match cstr with - | None | Some (_, None) -> - let evars, rel = mk_relation env evars car in - new_cstr_evar evars env rel - | Some (ty, Some rel) -> evars, rel - in - let rec aux evars env prod n = - if Int.equal n 0 then start evars env prod - else - match kind_of_term (Reduction.whd_all env prod) with - | Prod (na, ty, b) -> - if noccurn 1 b then - let b' = lift (-1) b in - let evars, rb = aux evars env b' (pred n) in - app_poly env evars pointwise_relation [| ty; b'; rb |] - else - let evars, rb = aux evars (Environ.push_rel (LocalAssum (na, ty)) env) b (pred n) in - app_poly env evars forall_relation - [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] - | _ -> raise Not_found - in - let rec find env c ty = function - | [] -> None - | arg :: args -> - try let evars, found = aux evars env ty (succ (List.length args)) in - Some (evars, found, c, ty, arg :: args) - with Not_found -> - let ty = whd_all env ty in - find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args - in find env c ty args - - let unlift_cstr env sigma = function - | None -> None - | Some codom -> Some (decomp_pointwise 1 codom) - - (** Looking up declared rewrite relations (instances of [RewriteRelation]) *) - let is_applied_rewrite_relation env sigma rels t = - match kind_of_term t with - | App (c, args) when Array.length args >= 2 -> - let head = if isApp c then fst (destApp c) else c in - if Globnames.is_global (coq_eq_ref ()) head then None - else - (try - let params, args = Array.chop (Array.length args - 2) args in - let env' = Environ.push_rel_context rels env in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma ((evar, _), evars, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in - let evars = Sigma.to_evar_map evars in - let evars, inst = - app_poly env (evars,Evar.Set.empty) - rewrite_relation_class [| evar; mkApp (c, params) |] in - let _ = Typeclasses.resolve_one_typeclass env' (goalevars evars) inst in - Some (it_mkProd_or_LetIn t rels) - with e when CErrors.noncritical e -> None) - | _ -> None - - -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 type_app_poly env env evd f args = - let evars, c = app_poly_nocheck env evd f args in - let evd', t = Typing.type_of env (goalevars evars) c in - (evd', cstrevars evars), c - -module PropGlobal = struct - module Consts = - struct - let relation_classes = ["Classes"; "RelationClasses"] - let morphisms = ["Classes"; "Morphisms"] - let relation = ["Relations";"Relation_Definitions"], "relation" - let app_poly = app_poly_nocheck - let arrow = find_global ["Program"; "Basics"] "arrow" - let coq_inverse = find_global ["Program"; "Basics"] "flip" - end - - module G = GlobalBindings(Consts) - - include G - include Consts - let inverse env evd car rel = - type_app_poly env env evd coq_inverse [| car ; car; mkProp; rel |] - (* app_poly env evd coq_inverse [| car ; car; mkProp; rel |] *) - -end - -module TypeGlobal = struct - module Consts = - struct - let relation_classes = ["Classes"; "CRelationClasses"] - let morphisms = ["Classes"; "CMorphisms"] - let relation = relation_classes, "crelation" - let app_poly = app_poly_check - let arrow = find_global ["Classes"; "CRelationClasses"] "arrow" - let coq_inverse = find_global ["Classes"; "CRelationClasses"] "flip" - end - - module G = GlobalBindings(Consts) - include G - include Consts - - - let inverse env (evd,cstrs) car rel = - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (sort, sigma, _) = Evarutil.new_Type ~rigid:Evd.univ_flexible env sigma in - let evd = Sigma.to_evar_map sigma in - app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |] - -end - -let sort_of_rel env evm rel = - Reductionops.sort_of_arity env evm (Retyping.get_type_of env evm rel) - -let is_applied_rewrite_relation = PropGlobal.is_applied_rewrite_relation - -(* let _ = *) -(* Hook.set Equality.is_applied_rewrite_relation is_applied_rewrite_relation *) - -let split_head = function - hd :: tl -> hd, tl - | [] -> assert(false) - -let eq_pb (ty, env, x, y as pb) (ty', env', x', y' as pb') = - pb == pb' || (ty == ty' && Constr.equal x x' && Constr.equal y y') - -let problem_inclusion x y = - List.for_all (fun pb -> List.exists (fun pb' -> eq_pb pb pb') y) x - -let evd_convertible env evd x y = - try - (* Unfortunately, the_conv_x might say they are unifiable even if some - unsolvable constraints remain, so we check that this unification - does not introduce any new problem. *) - let _, pbs = Evd.extract_all_conv_pbs evd in - let evd' = Evarconv.the_conv_x env x y evd in - let _, pbs' = Evd.extract_all_conv_pbs evd' in - if evd' == evd || problem_inclusion pbs' pbs then Some evd' - else None - with e when CErrors.noncritical e -> None - -let convertible env evd x y = - Reductionops.is_conv_leq env evd x y - -type hypinfo = { - prf : constr; - car : constr; - rel : constr; - sort : bool; (* true = Prop; false = Type *) - c1 : constr; - c2 : constr; - holes : Clenv.hole list; -} - -let get_symmetric_proof b = - if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof - -let error_no_relation () = error "Cannot find a relation to rewrite." - -let rec decompose_app_rel env evd t = - (** Head normalize for compatibility with the old meta mechanism *) - let t = Reductionops.whd_betaiota evd t in - match kind_of_term t with - | App (f, [||]) -> assert false - | App (f, [|arg|]) -> - let (f', argl, argr) = decompose_app_rel env evd arg in - let ty = Typing.unsafe_type_of env evd argl in - let f'' = mkLambda (Name default_dependent_ident, ty, - mkLambda (Name (Id.of_string "y"), lift 1 ty, - mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |]))) - in (f'', argl, argr) - | App (f, args) -> - let len = Array.length args in - let fargs = Array.sub args 0 (Array.length args - 2) in - let rel = mkApp (f, fargs) in - rel, args.(len - 2), args.(len - 1) - | _ -> error_no_relation () - -let decompose_app_rel env evd t = - let (rel, t1, t2) = decompose_app_rel env evd t in - let ty = Retyping.get_type_of env evd rel in - let () = if not (Reduction.is_arity env ty) then error_no_relation () in - (rel, t1, t2) - -let decompose_applied_relation env sigma (c,l) = - let open Context.Rel.Declaration in - let ctype = Retyping.get_type_of env sigma c in - let find_rel ty = - let sigma, cl = Clenv.make_evar_clause env sigma ty in - let sigma = Clenv.solve_evar_clause env sigma true cl l in - let { Clenv.cl_holes = holes; Clenv.cl_concl = t } = cl in - let (equiv, c1, c2) = decompose_app_rel env sigma t in - let ty1 = Retyping.get_type_of env sigma c1 in - let ty2 = Retyping.get_type_of env sigma c2 in - match evd_convertible env sigma ty1 ty2 with - | None -> None - | Some sigma -> - let sort = sort_of_rel env sigma equiv in - let args = Array.map_of_list (fun h -> h.Clenv.hole_evar) holes in - let value = mkApp (c, args) in - Some (sigma, { prf=value; - car=ty1; rel = equiv; sort = Sorts.is_prop sort; - c1=c1; c2=c2; holes }) - in - match find_rel ctype with - | Some c -> c - | None -> - let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) - match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with - | Some c -> c - | None -> error "Cannot find an homogeneous relation to rewrite." - -let rewrite_db = "rewrite" - -let conv_transparent_state = (Id.Pred.empty, Cpred.full) - -let _ = - Hints.add_hints_init - (fun () -> - Hints.create_hint_db false rewrite_db conv_transparent_state true) - -let rewrite_transparent_state () = - Hints.Hint_db.transparent_state (Hints.searchtable_map rewrite_db) - -let rewrite_core_unif_flags = { - Unification.modulo_conv_on_closed_terms = None; - Unification.use_metas_eagerly_in_conv_on_closed_terms = true; - Unification.use_evars_eagerly_in_conv_on_closed_terms = true; - Unification.modulo_delta = empty_transparent_state; - Unification.modulo_delta_types = full_transparent_state; - Unification.check_applied_meta_types = true; - Unification.use_pattern_unification = true; - Unification.use_meta_bound_pattern_unification = true; - Unification.frozen_evars = Evar.Set.empty; - Unification.restrict_conv_on_strict_subterms = false; - Unification.modulo_betaiota = false; - Unification.modulo_eta = true; -} - -(* Flags used for the setoid variant of "rewrite" and for the strategies - "hints"/"old_hints"/"terms" of "rewrite_strat", and for solving pre-existing - evars in "rewrite" (see unify_abs) *) -let rewrite_unif_flags = - let flags = rewrite_core_unif_flags in { - Unification.core_unify_flags = flags; - Unification.merge_unify_flags = flags; - Unification.subterm_unify_flags = flags; - Unification.allow_K_in_toplevel_higher_order_unification = true; - Unification.resolve_evars = true - } - -let rewrite_core_conv_unif_flags = { - rewrite_core_unif_flags with - Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; - Unification.modulo_delta_types = conv_transparent_state; - Unification.modulo_betaiota = true -} - -(* Fallback flags for the setoid variant of "rewrite" *) -let rewrite_conv_unif_flags = - let flags = rewrite_core_conv_unif_flags in { - Unification.core_unify_flags = flags; - Unification.merge_unify_flags = flags; - Unification.subterm_unify_flags = flags; - Unification.allow_K_in_toplevel_higher_order_unification = true; - Unification.resolve_evars = true - } - -(* Flags for "setoid_rewrite c"/"rewrite_strat -> c" *) -let general_rewrite_unif_flags () = - let ts = rewrite_transparent_state () in - let core_flags = - { rewrite_core_unif_flags with - Unification.modulo_conv_on_closed_terms = Some ts; - Unification.use_evars_eagerly_in_conv_on_closed_terms = true; - Unification.modulo_delta = ts; - Unification.modulo_delta_types = full_transparent_state; - Unification.modulo_betaiota = true } - in { - Unification.core_unify_flags = core_flags; - Unification.merge_unify_flags = core_flags; - Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = empty_transparent_state }; - Unification.allow_K_in_toplevel_higher_order_unification = true; - Unification.resolve_evars = true - } - -let refresh_hypinfo env sigma (is, cb) = - let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma cb in - let sigma, hypinfo = decompose_applied_relation env sigma cbl in - let { c1; c2; car; rel; prf; sort; holes } = hypinfo in - sigma, (car, rel, prf, c1, c2, holes, sort) - -(** FIXME: write this in the new monad interface *) -let solve_remaining_by env sigma holes by = - match by with - | None -> sigma - | Some tac -> - let map h = - if h.Clenv.hole_deps then None - else - let (evk, _) = destEvar (h.Clenv.hole_evar) in - Some evk - in - (** Only solve independent holes *) - let indep = List.map_filter map holes in - let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in - let solve_tac = match tac with - | Genarg.GenArg (Genarg.Glbwit tag, tac) -> - Ftactic.run (Geninterp.interp tag ist tac) (fun _ -> Proofview.tclUNIT ()) - in - let solve_tac = tclCOMPLETE solve_tac in - let solve sigma evk = - let evi = - try Some (Evd.find_undefined sigma evk) - with Not_found -> None - in - match evi with - | None -> sigma - (** Evar should not be defined, but just in case *) - | Some evi -> - let env = Environ.reset_with_named_context evi.evar_hyps env in - let ty = evi.evar_concl in - let c, sigma = Pfedit.refine_by_tactic env sigma ty solve_tac in - Evd.define evk c sigma - in - List.fold_left solve sigma indep - -let no_constraints cstrs = - fun ev _ -> not (Evar.Set.mem ev cstrs) - -let all_constraints cstrs = - fun ev _ -> Evar.Set.mem ev cstrs - -let poly_inverse sort = - if sort then PropGlobal.inverse else TypeGlobal.inverse - -type rewrite_proof = - | RewPrf of constr * constr - (** A Relation (R : rew_car -> rew_car -> Prop) and a proof of R rew_from rew_to *) - | RewCast of cast_kind - (** A proof of convertibility (with casts) *) - -type rewrite_result_info = { - rew_car : constr ; - (** A type *) - rew_from : constr ; - (** A term of type rew_car *) - rew_to : constr ; - (** A term of type rew_car *) - rew_prf : rewrite_proof ; - (** A proof of rew_from == rew_to *) - rew_evars : evars; -} - -type rewrite_result = -| Fail -| Identity -| Success of rewrite_result_info - -type 'a strategy_input = { state : 'a ; (* a parameter: for instance, a state *) - env : Environ.env ; - unfresh : Id.t list ; (* Unfresh names *) - term1 : constr ; - ty1 : types ; (* first term and its type (convertible to rew_from) *) - cstr : (bool (* prop *) * constr option) ; - evars : evars } - -type 'a pure_strategy = { strategy : - 'a strategy_input -> - 'a * rewrite_result (* the updated state and the "result" *) } - -type strategy = unit pure_strategy - -let symmetry env sort rew = - let { rew_evars = evars; rew_car = car; } = rew in - let (rew_evars, rew_prf) = match rew.rew_prf with - | RewCast _ -> (rew.rew_evars, rew.rew_prf) - | RewPrf (rel, prf) -> - try - let evars, symprf = get_symmetric_proof sort env evars car rel in - let prf = mkApp (symprf, [| rew.rew_from ; rew.rew_to ; prf |]) in - (evars, RewPrf (rel, prf)) - with Not_found -> - let evars, rel = poly_inverse sort env evars car rel in - (evars, RewPrf (rel, prf)) - in - { rew with rew_from = rew.rew_to; rew_to = rew.rew_from; rew_prf; rew_evars; } - -(* Matching/unifying the rewriting rule against [t] *) -let unify_eqn (car, rel, prf, c1, c2, holes, sort) l2r flags env (sigma, cstrs) by t = - try - let left = if l2r then c1 else c2 in - let sigma = Unification.w_unify ~flags env sigma CONV left t in - let sigma = Typeclasses.resolve_typeclasses ~filter:(no_constraints cstrs) - ~fail:true env sigma in - let evd = solve_remaining_by env sigma holes by in - let nf c = Evarutil.nf_evar evd (Reductionops.nf_meta evd c) in - let c1 = nf c1 and c2 = nf c2 - and rew_car = nf car and rel = nf rel - and prf = nf prf in - let ty1 = Retyping.get_type_of env evd c1 in - let ty2 = Retyping.get_type_of env evd c2 in - let () = if not (convertible env evd ty2 ty1) then raise Reduction.NotConvertible in - let rew_evars = evd, cstrs in - let rew_prf = RewPrf (rel, prf) in - let rew = { rew_evars; rew_prf; rew_car; rew_from = c1; rew_to = c2; } in - let rew = if l2r then rew else symmetry env sort rew in - Some rew - with - | e when Class_tactics.catchable e -> None - | Reduction.NotConvertible -> None - -let unify_abs (car, rel, prf, c1, c2) l2r sort env (sigma, cstrs) t = - try - let left = if l2r then c1 else c2 in - (* The pattern is already instantiated, so the next w_unify is - basically an eq_constr, except when preexisting evars occur in - either the lemma or the goal, in which case the eq_constr also - solved this evars *) - let sigma = Unification.w_unify ~flags:rewrite_unif_flags env sigma CONV left t in - let rew_evars = sigma, cstrs in - let rew_prf = RewPrf (rel, prf) in - let rew = { rew_car = car; rew_from = c1; rew_to = c2; rew_prf; rew_evars; } in - let rew = if l2r then rew else symmetry env sort rew in - Some rew - with - | e when Class_tactics.catchable e -> None - | Reduction.NotConvertible -> None - -type rewrite_flags = { under_lambdas : bool; on_morphisms : bool } - -let default_flags = { under_lambdas = true; on_morphisms = true; } - -let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None - -let make_eq () = -(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) -let make_eq_refl () = -(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) - -let get_rew_prf r = match r.rew_prf with - | RewPrf (rel, prf) -> rel, prf - | RewCast c -> - let rel = mkApp (make_eq (), [| r.rew_car |]) in - rel, mkCast (mkApp (make_eq_refl (), [| r.rew_car; r.rew_from |]), - c, mkApp (rel, [| r.rew_from; r.rew_to |])) - -let poly_subrelation sort = - if sort then PropGlobal.subrelation else TypeGlobal.subrelation - -let resolve_subrelation env avoid car rel sort prf rel' res = - if eq_constr rel rel' then res - else - let evars, app = app_poly_check env res.rew_evars (poly_subrelation sort) [|car; rel; rel'|] in - let evars, subrel = new_cstr_evar evars env app in - let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in - { res with - rew_prf = RewPrf (rel', appsub); - rew_evars = evars } - -let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) evars = - let evars, morph_instance, proj, sigargs, m', args, args' = - let first = match (Array.findi (fun _ b -> not (Option.is_empty b)) args') with - | Some i -> i - | None -> invalid_arg "resolve_morphism" in - let morphargs, morphobjs = Array.chop first args in - let morphargs', morphobjs' = Array.chop first args' in - let appm = mkApp(m, morphargs) in - let appmtype = Typing.unsafe_type_of env (goalevars evars) appm in - let cstrs = List.map - (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) - (Array.to_list morphobjs') - in - (* Desired signature *) - let evars, appmtype', signature, sigargs = - if b then PropGlobal.build_signature evars env appmtype cstrs cstr - else TypeGlobal.build_signature evars env appmtype cstrs cstr - in - (* Actual signature found *) - let cl_args = [| appmtype' ; signature ; appm |] in - let evars, app = app_poly_sort b env evars (if b then PropGlobal.proper_type else TypeGlobal.proper_type) - cl_args in - let env' = - let dosub, appsub = - if b then PropGlobal.do_subrelation, PropGlobal.apply_subrelation - else TypeGlobal.do_subrelation, TypeGlobal.apply_subrelation - in - Environ.push_named - (LocalDef (Id.of_string "do_subrelation", - snd (app_poly_sort b env evars dosub [||]), - snd (app_poly_nocheck env evars appsub [||]))) - env - in - let evars, morph = new_cstr_evar evars env' app in - evars, morph, morph, sigargs, appm, morphobjs, morphobjs' - in - let projargs, subst, evars, respars, typeargs = - Array.fold_left2 - (fun (acc, subst, evars, sigargs, typeargs') x y -> - let (carrier, relation), sigargs = split_head sigargs in - match relation with - | Some relation -> - let carrier = substl subst carrier - and relation = substl subst relation in - (match y with - | None -> - let evars, proof = - (if b then PropGlobal.proper_proof else TypeGlobal.proper_proof) - env evars carrier relation x in - [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' - | Some r -> - [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, - sigargs, r.rew_to :: typeargs') - | None -> - if not (Option.is_empty y) then - error "Cannot rewrite inside dependent arguments of a function"; - x :: acc, x :: subst, evars, sigargs, x :: typeargs') - ([], [], evars, sigargs, []) args args' - in - let proof = applistc proj (List.rev projargs) in - let newt = applistc m' (List.rev typeargs) in - match respars with - [ a, Some r ] -> evars, proof, substl subst a, substl subst r, oldt, fnewt newt - | _ -> assert(false) - -let apply_constraint env avoid car rel prf cstr res = - match snd cstr with - | None -> res - | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res - -let coerce env avoid cstr res = - let rel, prf = get_rew_prf res in - apply_constraint env avoid res.rew_car rel prf cstr res - -let apply_rule unify loccs : int pure_strategy = - let (nowhere_except_in,occs) = convert_occs loccs in - let is_occ occ = - if nowhere_except_in - then List.mem occ occs - else not (List.mem occ occs) - in - { strategy = fun { state = occ ; env ; unfresh ; - term1 = t ; ty1 = ty ; cstr ; evars } -> - let unif = if isEvar t then None else unify env evars t in - match unif with - | None -> (occ, Fail) - | Some rew -> - let occ = succ occ in - if not (is_occ occ) then (occ, Fail) - else if eq_constr t rew.rew_to then (occ, Identity) - else - let res = { rew with rew_car = ty } in - let rel, prf = get_rew_prf res in - let res = Success (apply_constraint env unfresh rew.rew_car rel prf cstr res) in - (occ, res) - } - -let apply_lemma l2r flags oc by loccs : strategy = { strategy = - fun ({ state = () ; env ; term1 = t ; evars = (sigma, cstrs) } as input) -> - let sigma, c = oc sigma in - let sigma, hypinfo = decompose_applied_relation env sigma c in - let { c1; c2; car; rel; prf; sort; holes } = hypinfo in - let rew = (car, rel, prf, c1, c2, holes, sort) in - let evars = (sigma, cstrs) in - let unify env evars t = - let rew = unify_eqn rew l2r flags env evars by t in - match rew with - | None -> None - | Some rew -> Some rew - in - let _, res = (apply_rule unify loccs).strategy { input with - state = 0 ; - evars } in - (), res - } - -let e_app_poly env evars f args = - let evars', c = app_poly_nocheck env !evars f args in - evars := evars'; - c - -let make_leibniz_proof env c ty r = - let evars = ref r.rew_evars in - let prf = - match r.rew_prf with - | RewPrf (rel, prf) -> - let rel = e_app_poly env evars coq_eq [| ty |] in - let prf = - e_app_poly env evars coq_f_equal - [| r.rew_car; ty; - mkLambda (Anonymous, r.rew_car, c); - r.rew_from; r.rew_to; prf |] - in RewPrf (rel, prf) - | RewCast k -> r.rew_prf - in - { rew_car = ty; rew_evars = !evars; - rew_from = subst1 r.rew_from c; rew_to = subst1 r.rew_to c; rew_prf = prf } - -let reset_env env = - let env' = Global.env_of_context (Environ.named_context_val env) in - Environ.push_rel_context (Environ.rel_context env) env' - -let fold_match ?(force=false) env sigma c = - let (ci, p, c, brs) = destCase c in - let cty = Retyping.get_type_of env sigma c in - let dep, pred, exists, (sk,eff) = - let env', ctx, body = - let ctx, pred = decompose_lam_assum p in - let env' = Environ.push_rel_context ctx env in - env', ctx, pred - in - let sortp = Retyping.get_sort_family_of env' sigma body in - let sortc = Retyping.get_sort_family_of env sigma cty in - let dep = not (noccurn 1 body) in - let pred = if dep then p else - it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx) - in - let sk = - if sortp == InProp then - if sortc == InProp then - if dep then case_dep_scheme_kind_from_prop - else case_scheme_kind_from_prop - else ( - if dep - then case_dep_scheme_kind_from_type_in_prop - else case_scheme_kind_from_type) - else ((* sortc <> InProp by typing *) - if dep - then case_dep_scheme_kind_from_type - else case_scheme_kind_from_type) - in - let exists = Ind_tables.check_scheme sk ci.ci_ind in - if exists || force then - dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind - else raise Not_found - in - let app = - let ind, args = Inductive.find_rectype env cty in - let pars, args = List.chop ci.ci_npar args in - let meths = List.map (fun br -> br) (Array.to_list brs) in - applist (mkConst sk, pars @ [pred] @ meths @ args @ [c]) - in - sk, (if exists then env else reset_env env), app, eff - -let unfold_match env sigma sk app = - match kind_of_term app with - | App (f', args) when eq_constant (fst (destConst f')) sk -> - let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in - Reductionops.whd_beta sigma (mkApp (v, args)) - | _ -> app - -let is_rew_cast = function RewCast _ -> true | _ -> false - -let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = - let rec aux { state ; env ; unfresh ; - term1 = t ; ty1 = ty ; cstr = (prop, cstr) ; evars } = - let cstr' = Option.map (fun c -> (ty, Some c)) cstr in - match kind_of_term t with - | App (m, args) -> - let rewrite_args state success = - let state, (args', evars', progress) = - Array.fold_left - (fun (state, (acc, evars, progress)) arg -> - if not (Option.is_empty progress) && not all then - state, (None :: acc, evars, progress) - else - let argty = Retyping.get_type_of env (goalevars evars) arg in - let state, res = s.strategy { state ; env ; - unfresh ; - term1 = arg ; ty1 = argty ; - cstr = (prop,None) ; - evars } in - let res' = - match res with - | Identity -> - let progress = if Option.is_empty progress then Some false else progress in - (None :: acc, evars, progress) - | Success r -> - (Some r :: acc, r.rew_evars, Some true) - | Fail -> (None :: acc, evars, progress) - in state, res') - (state, ([], evars, success)) args - in - let res = - match progress with - | None -> Fail - | Some false -> Identity - | Some true -> - let args' = Array.of_list (List.rev args') in - if Array.exists - (function - | None -> false - | Some r -> not (is_rew_cast r.rew_prf)) args' - then - let evars', prf, car, rel, c1, c2 = - resolve_morphism env unfresh t m args args' (prop, cstr') evars' - in - let res = { rew_car = ty; rew_from = c1; - rew_to = c2; rew_prf = RewPrf (rel, prf); - rew_evars = evars' } - in Success res - else - let args' = Array.map2 - (fun aorig anew -> - match anew with None -> aorig - | Some r -> r.rew_to) args args' - in - let res = { rew_car = ty; rew_from = t; - rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast; - rew_evars = evars' } - in Success res - in state, res - in - if flags.on_morphisms then - let mty = Retyping.get_type_of env (goalevars evars) m in - let evars, cstr', m, mty, argsl, args = - let argsl = Array.to_list args in - let lift = if prop then PropGlobal.lift_cstr else TypeGlobal.lift_cstr in - match lift env evars argsl m mty None with - | Some (evars, cstr', m, mty, args) -> - evars, Some cstr', m, mty, args, Array.of_list args - | None -> evars, None, m, mty, argsl, args - in - let state, m' = s.strategy { state ; env ; unfresh ; - term1 = m ; ty1 = mty ; - cstr = (prop, cstr') ; evars } in - match m' with - | Fail -> rewrite_args state None (* Standard path, try rewrite on arguments *) - | Identity -> rewrite_args state (Some false) - | Success r -> - (* We rewrote the function and get a proof of pointwise rel for the arguments. - We just apply it. *) - let prf = match r.rew_prf with - | RewPrf (rel, prf) -> - let app = if prop then PropGlobal.apply_pointwise - else TypeGlobal.apply_pointwise - in - RewPrf (app rel argsl, mkApp (prf, args)) - | x -> x - in - let res = - { rew_car = Reductionops.hnf_prod_appvect env (goalevars evars) r.rew_car args; - rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); - rew_prf = prf; rew_evars = r.rew_evars } - in - let res = - match prf with - | RewPrf (rel, prf) -> - Success (apply_constraint env unfresh res.rew_car - rel prf (prop,cstr) res) - | _ -> Success res - in state, res - else rewrite_args state None - - | Prod (n, x, b) when noccurn 1 b -> - let b = subst1 mkProp b in - let tx = Retyping.get_type_of env (goalevars evars) x - and tb = Retyping.get_type_of env (goalevars evars) b in - let arr = if prop then PropGlobal.arrow_morphism - else TypeGlobal.arrow_morphism - in - let (evars', mor), unfold = arr env evars tx tb x b in - let state, res = aux { state ; env ; unfresh ; - term1 = mor ; ty1 = ty ; - cstr = (prop,cstr) ; evars = evars' } in - let res = - match res with - | Success r -> Success { r with rew_to = unfold r.rew_to } - | Fail | Identity -> res - in state, res - - (* if x' = None && flags.under_lambdas then *) - (* let lam = mkLambda (n, x, b) in *) - (* let lam', occ = aux env lam occ None in *) - (* let res = *) - (* match lam' with *) - (* | None -> None *) - (* | Some (prf, (car, rel, c1, c2)) -> *) - (* Some (resolve_morphism env sigma t *) - (* ~fnewt:unfold_all *) - (* (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *) - (* cstr evars) *) - (* in res, occ *) - (* else *) - - | Prod (n, dom, codom) -> - let lam = mkLambda (n, dom, codom) in - let (evars', app), unfold = - if eq_constr ty mkProp then - (app_poly_sort prop env evars coq_all [| dom; lam |]), TypeGlobal.unfold_all - else - let forall = if prop then PropGlobal.coq_forall else TypeGlobal.coq_forall in - (app_poly_sort prop env evars forall [| dom; lam |]), TypeGlobal.unfold_forall - in - let state, res = aux { state ; env ; unfresh ; - term1 = app ; ty1 = ty ; - cstr = (prop,cstr) ; evars = evars' } in - let res = - match res with - | Success r -> Success { r with rew_to = unfold r.rew_to } - | Fail | Identity -> res - in state, res - -(* TODO: real rewriting under binders: introduce x x' (H : R x x') and rewrite with - H at any occurrence of x. Ask for (R ==> R') for the lambda. Formalize this. - B. Barras' idea is to have a context of relations, of length 1, with Σ for gluing - dependent relations and using projections to get them out. - *) - (* | Lambda (n, t, b) when flags.under_lambdas -> *) - (* let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in *) - (* let n'' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n' in *) - (* let n''' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n'' in *) - (* let rel = new_cstr_evar cstr env (mkApp (Lazy.force coq_relation, [|t|])) in *) - (* let env' = Environ.push_rel_context [(n'',None,lift 2 rel);(n'',None,lift 1 t);(n', None, t)] env in *) - (* let b' = s env' avoid b (Typing.type_of env' (goalevars evars) (lift 2 b)) (unlift_cstr env (goalevars evars) cstr) evars in *) - (* (match b' with *) - (* | Some (Some r) -> *) - (* let prf = match r.rew_prf with *) - (* | RewPrf (rel, prf) -> *) - (* let rel = pointwise_or_dep_relation n' t r.rew_car rel in *) - (* let prf = mkLambda (n', t, prf) in *) - (* RewPrf (rel, prf) *) - (* | x -> x *) - (* in *) - (* Some (Some { r with *) - (* rew_prf = prf; *) - (* rew_car = mkProd (n, t, r.rew_car); *) - (* rew_from = mkLambda(n, t, r.rew_from); *) - (* rew_to = mkLambda (n, t, r.rew_to) }) *) - (* | _ -> b') *) - - | Lambda (n, t, b) when flags.under_lambdas -> - let n' = name_app (fun id -> Tactics.fresh_id_in_env unfresh id env) n in - let open Context.Rel.Declaration in - let env' = Environ.push_rel (LocalAssum (n', t)) env in - let bty = Retyping.get_type_of env' (goalevars evars) b in - let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in - let state, b' = s.strategy { state ; env = env' ; unfresh ; - term1 = b ; ty1 = bty ; - cstr = (prop, unlift env evars cstr) ; - evars } in - let res = - match b' with - | Success r -> - let r = match r.rew_prf with - | RewPrf (rel, prf) -> - let point = if prop then PropGlobal.pointwise_or_dep_relation else - TypeGlobal.pointwise_or_dep_relation - in - let evars, rel = point env r.rew_evars n' t r.rew_car rel in - let prf = mkLambda (n', t, prf) in - { r with rew_prf = RewPrf (rel, prf); rew_evars = evars } - | x -> r - in - Success { r with - rew_car = mkProd (n, t, r.rew_car); - rew_from = mkLambda(n, t, r.rew_from); - rew_to = mkLambda (n, t, r.rew_to) } - | Fail | Identity -> b' - in state, res - - | Case (ci, p, c, brs) -> - let cty = Retyping.get_type_of env (goalevars evars) c in - let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in - let cstr' = Some eqty in - let state, c' = s.strategy { state ; env ; unfresh ; - term1 = c ; ty1 = cty ; - cstr = (prop, cstr') ; evars = evars' } in - let state, res = - match c' with - | Success r -> - let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in - let res = make_leibniz_proof env case ty r in - state, Success (coerce env unfresh (prop,cstr) res) - | Fail | Identity -> - if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then - let evars', eqty = app_poly_sort prop env evars coq_eq [| ty |] in - let cstr = Some eqty in - let state, found, brs' = Array.fold_left - (fun (state, found, acc) br -> - if not (Option.is_empty found) then - (state, found, fun x -> lift 1 br :: acc x) - else - let state, res = s.strategy { state ; env ; unfresh ; - term1 = br ; ty1 = ty ; - cstr = (prop,cstr) ; evars } in - match res with - | Success r -> (state, Some r, fun x -> mkRel 1 :: acc x) - | Fail | Identity -> (state, None, fun x -> lift 1 br :: acc x)) - (state, None, fun x -> []) brs - in - match found with - | Some r -> - let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' c'))) in - state, Success (make_leibniz_proof env ctxc ty r) - | None -> state, c' - else - match try Some (fold_match env (goalevars evars) t) with Not_found -> None with - | None -> state, c' - | Some (cst, _, t', eff (*FIXME*)) -> - let state, res = aux { state ; env ; unfresh ; - term1 = t' ; ty1 = ty ; - cstr = (prop,cstr) ; evars } in - let res = - match res with - | Success prf -> - Success { prf with - rew_from = t; - rew_to = unfold_match env (goalevars evars) cst prf.rew_to } - | x' -> c' - in state, res - in - let res = - match res with - | Success r -> - let rel, prf = get_rew_prf r in - Success (apply_constraint env unfresh r.rew_car rel prf (prop,cstr) r) - | Fail | Identity -> res - in state, res - | _ -> state, Fail - in { strategy = aux } - -let all_subterms = subterm true default_flags -let one_subterm = subterm false default_flags - -(** Requires transitivity of the rewrite step, if not a reduction. - Not tail-recursive. *) - -let transitivity state env unfresh prop (res : rewrite_result_info) (next : 'a pure_strategy) : - 'a * rewrite_result = - let state, nextres = - next.strategy { state ; env ; unfresh ; - term1 = res.rew_to ; ty1 = res.rew_car ; - cstr = (prop, get_opt_rew_rel res.rew_prf) ; - evars = res.rew_evars } - in - let res = - match nextres with - | Fail -> Fail - | Identity -> Success res - | Success res' -> - match res.rew_prf with - | RewCast c -> Success { res' with rew_from = res.rew_from } - | RewPrf (rew_rel, rew_prf) -> - match res'.rew_prf with - | RewCast _ -> Success { res with rew_to = res'.rew_to } - | RewPrf (res'_rel, res'_prf) -> - let trans = - if prop then PropGlobal.transitive_type - else TypeGlobal.transitive_type - in - let evars, prfty = - app_poly_sort prop env res'.rew_evars trans [| res.rew_car; rew_rel |] - in - let evars, prf = new_cstr_evar evars env prfty in - let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; - rew_prf; res'_prf |]) - in Success { res' with rew_from = res.rew_from; - rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) } - in state, res - -(** Rewriting strategies. - - Inspired by ELAN's rewriting strategies: - http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.21.4049 -*) - -module Strategies = - struct - - let fail : 'a pure_strategy = - { strategy = fun { state } -> state, Fail } - - let id : 'a pure_strategy = - { strategy = fun { state } -> state, Identity } - - let refl : 'a pure_strategy = - { strategy = - fun { state ; env ; - term1 = t ; ty1 = ty ; - cstr = (prop,cstr) ; evars } -> - let evars, rel = match cstr with - | None -> - let mkr = if prop then PropGlobal.mk_relation else TypeGlobal.mk_relation in - let evars, rty = mkr env evars ty in - new_cstr_evar evars env rty - | Some r -> evars, r - in - let evars, proof = - let proxy = - if prop then PropGlobal.proper_proxy_type - else TypeGlobal.proper_proxy_type - in - let evars, mty = app_poly_sort prop env evars proxy [| ty ; rel; t |] in - new_cstr_evar evars env mty - in - let res = Success { rew_car = ty; rew_from = t; rew_to = t; - rew_prf = RewPrf (rel, proof); rew_evars = evars } - in state, res - } - - let progress (s : 'a pure_strategy) : 'a pure_strategy = { strategy = - fun input -> - let state, res = s.strategy input in - match res with - | Fail -> state, Fail - | Identity -> state, Fail - | Success r -> state, Success r - } - - let seq first snd : 'a pure_strategy = { strategy = - fun ({ env ; unfresh ; cstr } as input) -> - let state, res = first.strategy input in - match res with - | Fail -> state, Fail - | Identity -> snd.strategy { input with state } - | Success res -> transitivity state env unfresh (fst cstr) res snd - } - - let choice fst snd : 'a pure_strategy = { strategy = - fun input -> - let state, res = fst.strategy input in - match res with - | Fail -> snd.strategy { input with state } - | Identity | Success _ -> state, res - } - - let try_ str : 'a pure_strategy = choice str id - - let check_interrupt str input = - Control.check_for_interrupt (); - str input - - let fix (f : 'a pure_strategy -> 'a pure_strategy) : 'a pure_strategy = - let rec aux input = (f { strategy = fun input -> check_interrupt aux input }).strategy input in - { strategy = aux } - - let any (s : 'a pure_strategy) : 'a pure_strategy = - fix (fun any -> try_ (seq s any)) - - let repeat (s : 'a pure_strategy) : 'a pure_strategy = - seq s (any s) - - let bu (s : 'a pure_strategy) : 'a pure_strategy = - fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s')) - - let td (s : 'a pure_strategy) : 'a pure_strategy = - fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s')) - - let innermost (s : 'a pure_strategy) : 'a pure_strategy = - fix (fun ins -> choice (one_subterm ins) s) - - let outermost (s : 'a pure_strategy) : 'a pure_strategy = - fix (fun out -> choice s (one_subterm out)) - - let lemmas cs : 'a pure_strategy = - List.fold_left (fun tac (l,l2r,by) -> - choice tac (apply_lemma l2r rewrite_unif_flags l by AllOccurrences)) - fail cs - - let inj_open hint = (); fun sigma -> - let ctx = Evd.evar_universe_context_of hint.Autorewrite.rew_ctx in - let sigma = Evd.merge_universe_context sigma ctx in - (sigma, (hint.Autorewrite.rew_lemma, NoBindings)) - - let old_hints (db : string) : 'a pure_strategy = - let rules = Autorewrite.find_rewrites db in - lemmas - (List.map (fun hint -> (inj_open hint, hint.Autorewrite.rew_l2r, - hint.Autorewrite.rew_tac)) rules) - - let hints (db : string) : 'a pure_strategy = { strategy = - fun ({ term1 = t } as input) -> - let rules = Autorewrite.find_matches db t in - let lemma hint = (inj_open hint, hint.Autorewrite.rew_l2r, - hint.Autorewrite.rew_tac) in - let lems = List.map lemma rules in - (lemmas lems).strategy input - } - - let reduce (r : Redexpr.red_expr) : 'a pure_strategy = { strategy = - fun { state = state ; env = env ; term1 = t ; ty1 = ty ; cstr = cstr ; evars = evars } -> - let rfn, ckind = Redexpr.reduction_of_red_expr env r in - let sigma = Sigma.Unsafe.of_evar_map (goalevars evars) in - let Sigma (t', sigma, _) = rfn.Reductionops.e_redfun env sigma t in - let evars' = Sigma.to_evar_map sigma in - if eq_constr t' t then - state, Identity - else - state, Success { rew_car = ty; rew_from = t; rew_to = t'; - rew_prf = RewCast ckind; - rew_evars = evars', cstrevars evars } - } - - let fold_glob c : 'a pure_strategy = { strategy = - fun { state ; env ; term1 = t ; ty1 = ty ; cstr ; evars } -> -(* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) - let sigma, c = Pretyping.understand_tcc env (goalevars evars) c in - let unfolded = - try Tacred.try_red_product env sigma c - with e when CErrors.noncritical e -> - error "fold: the term is not unfoldable !" - in - try - let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in - let c' = Evarutil.nf_evar sigma c in - state, Success { rew_car = ty; rew_from = t; rew_to = c'; - rew_prf = RewCast DEFAULTcast; - rew_evars = (sigma, snd evars) } - with e when CErrors.noncritical e -> state, Fail - } - - -end - -(** The strategy for a single rewrite, dealing with occurrences. *) - -(** A dummy initial clauseenv to avoid generating initial evars before - even finding a first application of the rewriting lemma, in setoid_rewrite - mode *) - -let rewrite_with l2r flags c occs : strategy = { strategy = - fun ({ state = () } as input) -> - let unify env evars t = - let (sigma, cstrs) = evars in - let (sigma, rew) = refresh_hypinfo env sigma c in - unify_eqn rew l2r flags env (sigma, cstrs) None t - in - let app = apply_rule unify occs in - let strat = - Strategies.fix (fun aux -> - Strategies.choice app (subterm true default_flags aux)) - in - let _, res = strat.strategy { input with state = 0 } in - ((), res) - } - -let apply_strategy (s : strategy) env unfresh concl (prop, cstr) evars = - let ty = Retyping.get_type_of env (goalevars evars) concl in - let _, res = s.strategy { state = () ; env ; unfresh ; - term1 = concl ; ty1 = ty ; - cstr = (prop, Some cstr) ; evars } in - res - -let solve_constraints env (evars,cstrs) = - let filter = all_constraints cstrs in - Typeclasses.resolve_typeclasses env ~filter ~split:false ~fail:true - (Typeclasses.mark_resolvables ~filter evars) - -let nf_zeta = - Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - -exception RewriteFailure of Pp.std_ppcmds - -type result = (evar_map * constr option * types) option option - -let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result = - let evdref = ref sigma in - let sort = Typing.e_sort_of env evdref concl in - let evars = (!evdref, Evar.Set.empty) in - let evars, cstr = - let prop, (evars, arrow) = - if is_prop_sort sort then true, app_poly_sort true env evars impl [||] - else false, app_poly_sort false env evars TypeGlobal.arrow [||] - in - match is_hyp with - | None -> - let evars, t = poly_inverse prop env evars (mkSort sort) arrow in - evars, (prop, t) - | Some _ -> evars, (prop, arrow) - in - let eq = apply_strategy strat env avoid concl cstr evars in - match eq with - | Fail -> None - | Identity -> Some None - | Success res -> - let (_, cstrs) = res.rew_evars in - let evars' = solve_constraints env res.rew_evars in - let newt = Evarutil.nf_evar evars' res.rew_to in - let evars = (* Keep only original evars (potentially instantiated) and goal evars, - the rest has been defined and substituted already. *) - Evar.Set.fold - (fun ev acc -> - if not (Evd.is_defined acc ev) then - user_err ~hdr:"rewrite" - (str "Unsolved constraint remaining: " ++ spc () ++ - Evd.pr_evar_info (Evd.find acc ev)) - else Evd.remove acc ev) - cstrs evars' - in - let res = match res.rew_prf with - | RewCast c -> None - | RewPrf (rel, p) -> - let p = nf_zeta env evars' (Evarutil.nf_evar evars' p) in - let term = - match abs with - | None -> p - | Some (t, ty) -> - let t = Evarutil.nf_evar evars' t in - let ty = Evarutil.nf_evar evars' ty in - mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) - in - let proof = match is_hyp with - | None -> term - | Some id -> mkApp (term, [| mkVar id |]) - in Some proof - in Some (Some (evars, res, newt)) - -(** Insert a declaration after the last declaration it depends on *) -let rec insert_dependent env decl accu hyps = match hyps with -| [] -> List.rev_append accu [decl] -| ndecl :: rem -> - if occur_var_in_decl env (NamedDecl.get_id ndecl) decl then - List.rev_append accu (decl :: hyps) - else - insert_dependent env decl (ndecl :: accu) rem - -let assert_replacing id newt tac = - let prf = Proofview.Goal.nf_enter { enter = begin fun gl -> - let concl = Proofview.Goal.concl gl in - let env = Proofview.Goal.env gl in - let ctx = Environ.named_context env in - let after, before = List.split_when (NamedDecl.get_id %> Id.equal id) ctx in - let nc = match before with - | [] -> assert false - | d :: rem -> insert_dependent env (LocalAssum (NamedDecl.get_id d, newt)) [] after @ rem - in - let env' = Environ.reset_with_named_context (val_of_named_context nc) env in - Refine.refine ~unsafe:false { run = begin fun sigma -> - let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma concl in - let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma newt in - let map d = - let n = NamedDecl.get_id d in - if Id.equal n id then ev' else mkVar n - in - let (e, _) = destEvar ev in - Sigma (mkEvar (e, Array.map_of_list map nc), sigma, p +> q) - end } - end } in - Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) - -let newfail n s = - Proofview.tclZERO (Refiner.FailError (n, lazy 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 treat sigma res = - match res with - | None -> newfail 0 (str "Nothing to rewrite") - | Some None -> if progress then newfail 0 (str"Failed to progress") - else Proofview.tclUNIT () - | Some (Some res) -> - let (undef, prf, newt) = res in - let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in - let gls = List.rev (Evd.fold_undefined fold undef []) in - match clause, prf with - | Some id, Some p -> - let tac = tclTHENLIST [ - Refine.refine ~unsafe:false { run = fun h -> Sigma.here p h }; - Proofview.Unsafe.tclNEWGOALS gls; - ] in - Proofview.Unsafe.tclEVARS undef <*> - tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) - | Some id, None -> - Proofview.Unsafe.tclEVARS undef <*> - convert_hyp_no_check (LocalAssum (id, newt)) <*> - beta_hyp id - | None, Some p -> - Proofview.Unsafe.tclEVARS undef <*> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let make = { run = begin fun sigma -> - let Sigma (ev, sigma, q) = Evarutil.new_evar env sigma newt in - Sigma (mkApp (p, [| ev |]), sigma, q) - end } in - Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls - end } - | None, None -> - Proofview.Unsafe.tclEVARS undef <*> - convert_concl_no_check newt DEFAULTcast - in - Proofview.Goal.nf_enter { enter = begin fun gl -> - let concl = Proofview.Goal.concl gl in - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let ty = match clause with - | None -> concl - | Some id -> Environ.named_type id env - in - let env = match clause with - | None -> env - | Some id -> - (** Only consider variables not depending on [id] *) - let ctx = Environ.named_context env in - let filter decl = not (occur_var_in_decl env id decl) in - let nctx = List.filter filter ctx in - Environ.reset_with_named_context (Environ.val_of_named_context nctx) env - in - try - let res = - cl_rewrite_clause_aux ?abs strat env [] sigma ty clause - in - let sigma = match origsigma with None -> sigma | Some sigma -> sigma in - treat sigma res <*> - (** For compatibility *) - beta <*> Proofview.shelve_unifiable - with - | PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) -> - raise (RewriteFailure (Himsg.explain_pretype_error env evd e)) - end } - -let tactic_init_setoid () = - try init_setoid (); Proofview.tclUNIT () - with e when CErrors.noncritical e -> Tacticals.New.tclFAIL 0 (str"Setoid library not loaded") - -let cl_rewrite_clause_strat progress strat clause = - tactic_init_setoid () <*> - (if progress then Proofview.tclPROGRESS else fun x -> x) - (Proofview.tclOR - (cl_rewrite_clause_newtac ~progress strat clause) - (fun (e, info) -> match e with - | RewriteFailure e -> - tclZEROMSG (str"setoid rewrite failed: " ++ e) - | Refiner.FailError (n, pp) -> - tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) - | e -> Proofview.tclZERO ~info e)) - -(** Setoid rewriting when called with "setoid_rewrite" *) -let cl_rewrite_clause l left2right occs clause = - let strat = rewrite_with left2right (general_rewrite_unif_flags ()) l occs in - cl_rewrite_clause_strat true strat clause - -(** Setoid rewriting when called with "rewrite_strat" *) -let cl_rewrite_clause_strat strat clause = - cl_rewrite_clause_strat false strat clause - -let apply_glob_constr c l2r occs = (); fun ({ state = () ; env = env } as input) -> - let c sigma = - let (sigma, c) = Pretyping.understand_tcc env sigma c in - (sigma, (c, NoBindings)) - in - let flags = general_rewrite_unif_flags () in - (apply_lemma l2r flags c None occs).strategy input - -let interp_glob_constr_list env = - let make c = (); fun sigma -> - let sigma, c = Pretyping.understand_tcc env sigma c in - (sigma, (c, NoBindings)) - in - List.map (fun c -> make c, true, None) - -(* Syntax for rewriting with strategies *) - -type unary_strategy = - Subterms | Subterm | Innermost | Outermost - | Bottomup | Topdown | Progress | Try | Any | Repeat - -type binary_strategy = - | Compose | Choice - -type ('constr,'redexpr) strategy_ast = - | StratId | StratFail | StratRefl - | StratUnary of unary_strategy * ('constr,'redexpr) strategy_ast - | StratBinary of binary_strategy - * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast - | StratConstr of 'constr * bool - | StratTerms of 'constr list - | StratHints of bool * string - | StratEval of 'redexpr - | StratFold of 'constr - -let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function - | StratId | StratFail | StratRefl as s -> s - | StratUnary (s, str) -> StratUnary (s, map_strategy f g str) - | StratBinary (s, str, str') -> StratBinary (s, map_strategy f g str, map_strategy f g str') - | StratConstr (c, b) -> StratConstr (f c, b) - | StratTerms l -> StratTerms (List.map f l) - | StratHints (b, id) -> StratHints (b, id) - | StratEval r -> StratEval (g r) - | StratFold c -> StratFold (f c) - -let pr_ustrategy = function -| Subterms -> str "subterms" -| Subterm -> str "subterm" -| Innermost -> str "innermost" -| Outermost -> str "outermost" -| Bottomup -> str "bottomup" -| Topdown -> str "topdown" -| Progress -> str "progress" -| Try -> str "try" -| Any -> str "any" -| Repeat -> str "repeat" - -let paren p = str "(" ++ p ++ str ")" - -let rec pr_strategy prc prr = function -| StratId -> str "id" -| StratFail -> str "fail" -| StratRefl -> str "refl" -| StratUnary (s, str) -> - pr_ustrategy s ++ spc () ++ paren (pr_strategy prc prr str) -| StratBinary (Choice, str1, str2) -> - str "choice" ++ spc () ++ paren (pr_strategy prc prr str1) ++ spc () ++ - paren (pr_strategy prc prr str2) -| StratBinary (Compose, str1, str2) -> - pr_strategy prc prr str1 ++ str ";" ++ spc () ++ pr_strategy prc prr str2 -| StratConstr (c, true) -> prc c -| StratConstr (c, false) -> str "<-" ++ spc () ++ prc c -| StratTerms cl -> str "terms" ++ spc () ++ pr_sequence prc cl -| StratHints (old, id) -> - let cmd = if old then "old_hints" else "hints" in - str cmd ++ spc () ++ str id -| StratEval r -> str "eval" ++ spc () ++ prr r -| StratFold c -> str "fold" ++ spc () ++ prc c - -let rec strategy_of_ast = function - | StratId -> Strategies.id - | StratFail -> Strategies.fail - | StratRefl -> Strategies.refl - | StratUnary (f, s) -> - let s' = strategy_of_ast s in - let f' = match f with - | Subterms -> all_subterms - | Subterm -> one_subterm - | Innermost -> Strategies.innermost - | Outermost -> Strategies.outermost - | Bottomup -> Strategies.bu - | Topdown -> Strategies.td - | Progress -> Strategies.progress - | Try -> Strategies.try_ - | Any -> Strategies.any - | Repeat -> Strategies.repeat - in f' s' - | StratBinary (f, s, t) -> - let s' = strategy_of_ast s in - let t' = strategy_of_ast t in - let f' = match f with - | Compose -> Strategies.seq - | Choice -> Strategies.choice - in f' s' t' - | StratConstr (c, b) -> { strategy = apply_glob_constr (fst c) b AllOccurrences } - | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id - | StratTerms l -> { strategy = - (fun ({ state = () ; env } as input) -> - let l' = interp_glob_constr_list env (List.map fst l) in - (Strategies.lemmas l').strategy input) - } - | StratEval r -> { strategy = - (fun ({ state = () ; env ; evars } as input) -> - let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in - (Strategies.reduce r_interp).strategy { input with - evars = (sigma,cstrevars evars) }) } - | StratFold c -> Strategies.fold_glob (fst c) - - -(* By default the strategy for "rewrite_db" is top-down *) - -let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l) - -let declare_an_instance n s args = - (((Loc.ghost,Name n),None), Explicit, - CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None), - 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 ()) - binders instance (Some (true, CRecord (Loc.ghost,fields))) - ~global ~generalize:false ~refine:false Hints.empty_hint_info - -let declare_instance_refl global binders a aeq n lemma = - let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" - in anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "reflexivity"),lemma)] - -let declare_instance_sym global binders a aeq n lemma = - let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" - in anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "symmetry"),lemma)] - -let declare_instance_trans global binders a aeq n lemma = - let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" - in anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "transitivity"),lemma)] - -let declare_relation ?(binders=[]) a aeq n refl symm trans = - init_setoid (); - let global = not (Locality.make_section_locality (Locality.LocalityFixme.consume ())) in - let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" - in ignore(anew_instance global binders instance []); - match (refl,symm,trans) with - (None, None, None) -> () - | (Some lemma1, None, None) -> - ignore (declare_instance_refl global binders a aeq n lemma1) - | (None, Some lemma2, None) -> - ignore (declare_instance_sym global binders a aeq n lemma2) - | (None, None, Some lemma3) -> - ignore (declare_instance_trans global binders a aeq n lemma3) - | (Some lemma1, Some lemma2, None) -> - ignore (declare_instance_refl global binders a aeq n lemma1); - ignore (declare_instance_sym global binders a aeq n lemma2) - | (Some lemma1, None, Some lemma3) -> - let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in - let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" - in ignore( - anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "PreOrder_Reflexive"), lemma1); - (Ident (Loc.ghost,Id.of_string "PreOrder_Transitive"),lemma3)]) - | (None, Some lemma2, Some lemma3) -> - let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" - in ignore( - anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "PER_Symmetric"), lemma2); - (Ident (Loc.ghost,Id.of_string "PER_Transitive"),lemma3)]) - | (Some lemma1, Some lemma2, Some lemma3) -> - let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in - let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" - in ignore( - anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), lemma1); - (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), lemma2); - (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), lemma3)]) - -let cHole = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) - -let proper_projection r ty = - let ctx, inst = decompose_prod_assum ty in - let mor, args = destApp inst in - let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in - let app = mkApp (Lazy.force PropGlobal.proper_proj, - Array.append args [| instarg |]) in - it_mkLambda_or_LetIn app ctx - -let declare_projection n instance_id r = - let poly = Global.is_polymorphic r in - let env = Global.env () in - let sigma = Evd.from_env env in - let sigma,c = Evd.fresh_global env sigma r in - let ty = Retyping.get_type_of env sigma c in - let term = proper_projection c ty in - let sigma, typ = Typing.type_of env sigma term in - let ctx, typ = decompose_prod_assum typ in - let typ = - let n = - let rec aux t = - match kind_of_term t with - | App (f, [| a ; a' ; rel; rel' |]) - when Globnames.is_global (PropGlobal.respectful_ref ()) f -> - succ (aux rel') - | _ -> 0 - in - let init = - match kind_of_term typ with - App (f, args) when Globnames.is_global (PropGlobal.respectful_ref ()) f -> - mkApp (f, fst (Array.chop (Array.length args - 2) args)) - | _ -> typ - in aux init - in - let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ - in it_mkProd_or_LetIn ccl ctx - in - let typ = it_mkProd_or_LetIn typ ctx in - let pl, ctx = Evd.universe_context sigma in - let cst = - Declare.definition_entry ~types:typ ~poly ~univs:ctx term - in - ignore(Declare.declare_constant n - (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) - -let build_morphism_signature env sigma m = - let m,ctx = Constrintern.interp_constr env sigma m in - let sigma = Evd.from_ctx ctx in - let t = Typing.unsafe_type_of env sigma m in - let cstrs = - let rec aux t = - match kind_of_term t with - | Prod (na, a, b) -> - None :: aux b - | _ -> [] - in aux t - in - let evars, t', sig_, cstrs = - PropGlobal.build_signature (sigma, Evar.Set.empty) env t cstrs None in - let evd = ref evars in - let _ = List.iter - (fun (ty, rel) -> - Option.iter (fun rel -> - let default = e_app_poly env evd PropGlobal.default_relation [| ty; rel |] in - ignore(e_new_cstr_evar env evd default)) - rel) - cstrs - in - let morph = e_app_poly env evd PropGlobal.proper_type [| t; sig_; m |] in - let evd = solve_constraints env !evd in - let evd = Evd.nf_constraints evd in - let m = Evarutil.nf_evars_universes evd morph in - Pretyping.check_evars env Evd.empty evd m; - Evd.evar_universe_context evd, m - -let default_morphism sign m = - let env = Global.env () in - let sigma = Evd.from_env env in - let t = Typing.unsafe_type_of env sigma m in - let evars, _, sign, cstrs = - PropGlobal.build_signature (sigma, Evar.Set.empty) env t (fst sign) (snd sign) - in - let evars, morph = app_poly_check env evars PropGlobal.proper_type [| t; sign; m |] in - let evars, mor = resolve_one_typeclass env (goalevars evars) morph in - mor, proper_projection mor morph - -let add_setoid global binders a aeq t n = - init_setoid (); - let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in - let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in - let _lemma_trans = declare_instance_trans global binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" - in ignore( - anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); - (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); - (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) - - -let make_tactic name = - let open Tacexpr in - let loc = Loc.ghost in - let tacpath = Libnames.qualid_of_string name in - let tacname = Qualid (loc, tacpath) in - TacArg (loc, TacCall (loc, tacname, [])) - -let add_morphism_infer glob m n = - init_setoid (); - let poly = Flags.is_universe_polymorphism () in - let instance_id = add_suffix n "_Proper" in - let env = Global.env () in - let evd = Evd.from_env env in - let uctx, instance = build_morphism_signature env evd m in - if Lib.is_modtype () then - let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id - (Entries.ParameterEntry - (None,poly,(instance,Evd.evar_context_universe_context uctx),None), - 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)); - declare_projection n instance_id (ConstRef cst) - else - let kind = Decl_kinds.Global, poly, - Decl_kinds.DefinitionBody Decl_kinds.Instance - in - let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in - let hook _ = function - | Globnames.ConstRef cst -> - add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info - glob poly (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) - | _ -> assert false - in - let hook = Lemmas.mk_hook hook in - Flags.silently - (fun () -> - Lemmas.start_proof instance_id kind (Evd.from_ctx uctx) instance hook; - ignore (Pfedit.by (Tacinterp.interp tac))) () - -let add_morphism glob binders m s n = - init_setoid (); - let poly = Flags.is_universe_polymorphism () in - let instance_id = add_suffix n "_Proper" in - let instance = - (((Loc.ghost,Name instance_id),None), Explicit, - CAppExpl (Loc.ghost, - (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), - [cHole; s; m])) - in - let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - ignore(new_instance ~global:glob poly binders instance - (Some (true, CRecord (Loc.ghost,[]))) - ~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 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]))) - in - List.iter - (fun (_,binding) -> - match binding with - Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) -> - check_freemetas_is_empty rebus freemetas - | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_), - {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) -> - check_freemetas_is_empty rebus1 freemetas1 ; - check_freemetas_is_empty rebus2 freemetas2 - ) metas - -(* Find a subterm which matches the pattern to rewrite for "rewrite" *) -let unification_rewrite l2r c1 c2 sigma prf car rel but env = - let (sigma,c') = - try - (* ~flags:(false,true) to allow to mark occurrences that must not be - rewritten simply by replacing them with let-defined definitions - in the context *) - Unification.w_unify_to_subterm - ~flags:rewrite_unif_flags - env sigma ((if l2r then c1 else c2),but) - with - | ex when Pretype_errors.precatchable_exception ex -> - (* ~flags:(true,true) to make Ring work (since it really - exploits conversion) *) - Unification.w_unify_to_subterm - ~flags:rewrite_conv_unif_flags - env sigma ((if l2r then c1 else c2),but) - in - let nf c = Evarutil.nf_evar sigma c in - 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; - 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 - let abs = prf, prfty in - let prf = mkRel 1 in - let res = (car, rel, prf, c1, c2) in - abs, sigma, res, Sorts.is_prop sort - -let get_hyp gl (c,l) clause l2r = - let evars = Tacmach.New.project gl in - let env = Tacmach.New.pf_env gl in - let sigma, hi = decompose_applied_relation env evars (c,l) in - let but = match clause with - | Some id -> Tacmach.New.pf_get_hyp_typ id gl - | None -> Evarutil.nf_evar evars (Tacmach.New.pf_concl gl) - in - unification_rewrite l2r hi.c1 hi.c2 sigma hi.prf hi.car hi.rel but env - -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 *) - -(** Setoid rewriting when called with "rewrite" *) -let general_s_rewrite cl l2r occs (c,l) ~new_goals = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let abs, evd, res, sort = get_hyp gl (c,l) cl l2r in - let unify env evars t = unify_abs res l2r sort env evars t in - let app = apply_rule unify occs in - let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in - let substrat = Strategies.fix recstrat in - let strat = { strategy = fun ({ state = () } as input) -> - let _, res = substrat.strategy { input with state = 0 } in - (), res - } - in - let origsigma = Tacmach.New.project gl in - tactic_init_setoid () <*> - Proofview.tclOR - (tclPROGRESS - (tclTHEN - (Proofview.Unsafe.tclEVARS evd) - (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl))) - (fun (e, info) -> match e with - | RewriteFailure e -> - tclFAIL 0 (str"setoid rewrite failed: " ++ e) - | e -> Proofview.tclZERO ~info e) - end } - -let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite - -(** [setoid_]{reflexivity,symmetry,transitivity} tactics *) - -let not_declared env ty rel = - tclFAIL 0 - (str" The relation " ++ Printer.pr_constr_env env Evd.empty rel ++ str" is not a declared " ++ - str ty ++ str" relation. Maybe you need to require the Coq.Classes.RelationClasses library") - -let setoid_proof ty fn fallback = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let concl = Proofview.Goal.concl gl in - Proofview.tclORELSE - begin - try - let rel, _, _ = decompose_app_rel env sigma concl in - let (sigma, t) = Typing.type_of env sigma rel in - let car = RelDecl.get_type (List.hd (fst (Reduction.dest_prod env t))) in - (try init_relation_classes () with _ -> raise Not_found); - fn env sigma car rel - with e -> Proofview.tclZERO e - end - begin function - | e -> - Proofview.tclORELSE - fallback - begin function (e', info) -> match e' with - | Hipattern.NoEquationFound -> - begin match e with - | (Not_found, _) -> - let rel, _, _ = decompose_app_rel env sigma concl in - not_declared env ty rel - | (e, info) -> Proofview.tclZERO ~info e - end - | e' -> Proofview.tclZERO ~info e' - end - end - end } - -let tac_open ((evm,_), c) tac = - (tclTHEN (Proofview.Unsafe.tclEVARS evm) (tac c)) - -let poly_proof getp gett env evm car rel = - if Sorts.is_prop (sort_of_rel env evm rel) then - getp env (evm,Evar.Set.empty) car rel - else gett env (evm,Evar.Set.empty) car rel - -let setoid_reflexivity = - setoid_proof "reflexive" - (fun env evm car rel -> - tac_open (poly_proof PropGlobal.get_reflexive_proof - TypeGlobal.get_reflexive_proof - env evm car rel) - (fun c -> tclCOMPLETE (apply c))) - (reflexivity_red true) - -let setoid_symmetry = - setoid_proof "symmetric" - (fun env evm car rel -> - tac_open - (poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof - env evm car rel) - (fun c -> apply c)) - (symmetry_red true) - -let setoid_transitivity c = - setoid_proof "transitive" - (fun env evm car rel -> - tac_open (poly_proof PropGlobal.get_transitive_proof TypeGlobal.get_transitive_proof - env evm car rel) - (fun proof -> match c with - | None -> eapply proof - | Some c -> apply_with_bindings (proof,ImplicitBindings [ c ]))) - (transitivity_red true c) - -let setoid_symmetry_in id = - Proofview.V82.tactic (fun gl -> - let ctype = pf_unsafe_type_of gl (mkVar id) in - let binders,concl = decompose_prod_assum ctype in - let (equiv, args) = decompose_app concl in - let rec split_last_two = function - | [c1;c2] -> [],(c1, c2) - | x::y::z -> let l,res = split_last_two (y::z) in x::l, res - | _ -> error "Cannot find an equivalence relation to rewrite." - in - let others,(c1,c2) = split_last_two args in - let he,c1,c2 = mkApp (equiv, Array.of_list others),c1,c2 in - let new_hyp' = mkApp (he, [| c2 ; c1 |]) in - let new_hyp = it_mkProd_or_LetIn new_hyp' binders in - Proofview.V82.of_tactic - (tclTHENLAST - (Tactics.assert_after_replacing id new_hyp) - (tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ])) - gl) - -let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity -let _ = Hook.set Tactics.setoid_symmetry setoid_symmetry -let _ = Hook.set Tactics.setoid_symmetry_in setoid_symmetry_in -let _ = Hook.set Tactics.setoid_transitivity setoid_transitivity - -let get_lemma_proof f env evm x y = - let (evm, _), c = f env (evm,Evar.Set.empty) x y in - evm, c - -let get_reflexive_proof = - get_lemma_proof PropGlobal.get_reflexive_proof - -let get_symmetric_proof = - get_lemma_proof PropGlobal.get_symmetric_proof - -let get_transitive_proof = - get_lemma_proof PropGlobal.get_transitive_proof - diff --git a/ltac/rewrite.mli b/ltac/rewrite.mli deleted file mode 100644 index 35c448351..000000000 --- a/ltac/rewrite.mli +++ /dev/null @@ -1,117 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* strategy - -val map_strategy : ('a -> 'b) -> ('c -> 'd) -> - ('a, 'c) strategy_ast -> ('b, 'd) strategy_ast - -val pr_strategy : ('a -> Pp.std_ppcmds) -> ('b -> Pp.std_ppcmds) -> - ('a, 'b) strategy_ast -> Pp.std_ppcmds - -(** Entry point for user-level "rewrite_strat" *) -val cl_rewrite_clause_strat : strategy -> Id.t option -> unit Proofview.tactic - -(** Entry point for user-level "setoid_rewrite" *) -val cl_rewrite_clause : - interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) -> - bool -> Locus.occurrences -> Id.t option -> unit Proofview.tactic - -val is_applied_rewrite_relation : - env -> evar_map -> Context.Rel.t -> constr -> types option - -val declare_relation : - ?binders:local_binder list -> constr_expr -> constr_expr -> Id.t -> - constr_expr option -> constr_expr option -> constr_expr option -> unit - -val add_setoid : - bool -> local_binder list -> constr_expr -> constr_expr -> constr_expr -> - Id.t -> unit - -val add_morphism_infer : bool -> constr_expr -> Id.t -> unit - -val add_morphism : - bool -> local_binder list -> constr_expr -> constr_expr -> Id.t -> unit - -val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr - -val get_symmetric_proof : env -> evar_map -> constr -> constr -> evar_map * constr - -val get_transitive_proof : env -> evar_map -> constr -> constr -> evar_map * constr - -val default_morphism : - (types * constr option) option list * (types * types option) option -> - constr -> constr * constr - -val setoid_symmetry : unit Proofview.tactic - -val setoid_symmetry_in : Id.t -> unit Proofview.tactic - -val setoid_reflexivity : unit Proofview.tactic - -val setoid_transitivity : constr option -> unit Proofview.tactic - - -val apply_strategy : - strategy -> - Environ.env -> - Names.Id.t list -> - Term.constr -> - bool * Term.constr -> - evars -> rewrite_result diff --git a/ltac/tacarg.ml b/ltac/tacarg.ml deleted file mode 100644 index 42552c484..000000000 --- a/ltac/tacarg.ml +++ /dev/null @@ -1,26 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -| _ -> assert false - -let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> - let Val.Dyn (t, _) = v in - match Val.eq t (val_tag wit) with - | None -> false - | Some Refl -> true - -let prj : type a. a Val.typ -> Val.t -> a option = fun t v -> - let Val.Dyn (t', x) = v in - match Val.eq t t' with - | None -> None - | Some Refl -> Some x - -let in_gen wit v = Val.Dyn (val_tag wit, v) -let out_gen wit v = match prj (val_tag wit) v with None -> assert false | Some x -> x - -module Value = -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 - else if has_type v (topwit wit_constr_under_binders) then - let vars, c = out_gen (topwit wit_constr_under_binders) v in - match vars with [] -> Some c | _ -> None - else None - -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 - -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 - -let to_list v = prj Val.typ_list v - -let to_option v = prj Val.typ_opt v - -let to_pair v = prj Val.typ_pair v - -end - -let is_variable env id = - Id.List.mem id (Termops.ids_of_named_context (Environ.named_context env)) - -(* Transforms an id into a constr if possible, or fails with Not_found *) -let constr_of_id env id = - Term.mkVar (let _ = Environ.lookup_named id env in 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 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 - | _, IntroNaming (IntroIdentifier id) -> id - | _ -> fail () - else if has_type v (topwit wit_var) then - out_gen (topwit wit_var) v - else match Value.to_constr v with - | None -> fail () - | Some c -> - (* We need it fresh for intro e.g. in "Tac H = clear H; intro H" *) - if isVar c && not (fresh && is_variable env (destVar c)) then - destVar c - else fail () - - -(* Interprets, if possible, a constr to an identifier which may not - be fresh but suitable to be given to the fresh tactic. Works for - vars, constants, inductive, constructors and sorts. *) -let coerce_to_ident_not_fresh g env v = -let id_of_name = function - | Names.Anonymous -> Id.of_string "x" - | Names.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 - | _, IntroNaming (IntroIdentifier id) -> id - | _ -> fail () - else if has_type v (topwit wit_var) then - out_gen (topwit wit_var) v - else - match Value.to_constr v with - | None -> fail () - | Some c -> - match Constr.kind c with - | Var id -> id - | Meta m -> id_of_name (Evd.meta_name g m) - | Evar (kn,_) -> - begin match Evd.evar_ident kn g with - | None -> fail () - | Some id -> id - end - | Const (cst,_) -> Label.to_id (Constant.label cst) - | Construct (cstr,_) -> - let ref = Globnames.ConstructRef cstr in - let basename = Nametab.basename_of_global ref in - basename - | Ind (ind,_) -> - let ref = Globnames.IndRef ind in - let basename = Nametab.basename_of_global ref in - basename - | Sort s -> - begin - match s with - | Prop _ -> Label.to_id (Label.make "Prop") - | Type _ -> Label.to_id (Label.make "Type") - end - | _ -> fail() - - -let coerce_to_intro_pattern env 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 - let id = out_gen (topwit wit_var) v in - IntroNaming (IntroIdentifier id) - else match Value.to_constr v with - | Some c when isVar c -> - (* This happens e.g. in definitions like "Tac H = clear H; intro H" *) - (* but also in "destruct H as (H,H')" *) - IntroNaming (IntroIdentifier (destVar c)) - | _ -> raise (CannotCoerceTo "an introduction pattern") - -let coerce_to_intro_pattern_naming env v = - match coerce_to_intro_pattern env v with - | IntroNaming pat -> pat - | _ -> 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 - | _ -> raise (CannotCoerceTo "a hint base name") - 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 - | _, IntroNaming (IntroIdentifier id) -> - (try ([], constr_of_id env id) with Not_found -> fail ()) - | _ -> fail () - else if has_type v (topwit wit_constr) then - let c = out_gen (topwit wit_constr) v in - ([], c) - else if has_type v (topwit wit_constr_under_binders) then - out_gen (topwit wit_constr_under_binders) v - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - (try [], constr_of_id env id with Not_found -> fail ()) - 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 - raise (CannotCoerceTo "an untyped term") - -let coerce_to_closed_constr env v = - let ids,c = coerce_to_constr env v in - let () = if not (List.is_empty ids) then raise (CannotCoerceTo "a term") in - c - -let coerce_to_evaluable_ref env 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 - | _, IntroNaming (IntroIdentifier id) when is_variable env id -> EvalVarRef id - | _ -> fail () - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - if Id.List.mem id (Termops.ids_of_context env) then EvalVarRef id - else fail () - else if has_type v (topwit wit_ref) then - let open Globnames in - let r = out_gen (topwit wit_ref) v in - match r with - | VarRef var -> EvalVarRef var - | ConstRef c -> EvalConstRef c - | IndRef _ | ConstructRef _ -> fail () - else - match Value.to_constr v with - | Some c when isConst c -> EvalConstRef (Univ.out_punivs (destConst c)) - | Some c when isVar c -> EvalVarRef (destVar c) - | _ -> fail () - in if Tacred.is_evaluable env ev then ev else fail () - -let coerce_to_constr_list env v = - let v = Value.to_list v in - match v with - | Some l -> - let map v = coerce_to_closed_constr env v in - List.map map l - | None -> raise (CannotCoerceTo "a term list") - -let coerce_to_intro_pattern_list loc env v = - match Value.to_list v with - | None -> raise (CannotCoerceTo "an intro pattern list") - | Some l -> - let map v = (loc, coerce_to_intro_pattern env v) in - List.map map l - -let coerce_to_hyp env 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 - | _ -> fail () - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - if is_variable env id then id else fail () - else match Value.to_constr v with - | Some c when isVar c -> destVar c - | _ -> fail () - -let coerce_to_hyp_list env v = - let v = Value.to_list v in - match v with - | Some l -> - let map n = coerce_to_hyp env n in - List.map map l - | None -> raise (CannotCoerceTo "a variable list") - -(* Interprets a qualified name *) -let coerce_to_reference env v = - let v = Value.normalize v in - match Value.to_constr v with - | Some c -> - begin - try Globnames.global_of_constr c - with Not_found -> raise (CannotCoerceTo "a reference") - end - | None -> raise (CannotCoerceTo "a reference") - -(* Quantified named or numbered hypothesis or hypothesis in context *) -(* (as in Inversion) *) -let coerce_to_quantified_hypothesis 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 - | _, IntroNaming (IntroIdentifier id) -> NamedHyp id - | _ -> raise (CannotCoerceTo "a quantified hypothesis") - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - NamedHyp id - else if has_type v (topwit wit_int) then - AnonHyp (out_gen (topwit wit_int) v) - else match Value.to_constr v with - | Some c when isVar c -> NamedHyp (destVar c) - | _ -> raise (CannotCoerceTo "a quantified hypothesis") - -(* Quantified named or numbered hypothesis or hypothesis in context *) -(* (as in Inversion) *) -let coerce_to_decl_or_quant_hyp env v = - let v = Value.normalize v in - if has_type v (topwit wit_int) then - AnonHyp (out_gen (topwit wit_int) v) - else - try coerce_to_quantified_hypothesis v - with CannotCoerceTo _ -> - raise (CannotCoerceTo "a declared or quantified hypothesis") - -let coerce_to_int_or_var_list v = - match Value.to_list v with - | None -> raise (CannotCoerceTo "an int list") - | Some l -> - let map n = ArgArg (coerce_to_int n) in - List.map map l diff --git a/ltac/taccoerce.mli b/ltac/taccoerce.mli deleted file mode 100644 index 0b67f8726..000000000 --- a/ltac/taccoerce.mli +++ /dev/null @@ -1,96 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t - (** Eliminated the leading dynamic type casts. *) - - val of_constr : constr -> t - val to_constr : t -> constr option - val of_uconstr : Glob_term.closed_glob_constr -> t - val to_uconstr : t -> Glob_term.closed_glob_constr option - val of_int : int -> t - val to_int : t -> int option - val to_list : t -> t list option - val to_option : t -> t option option - val to_pair : t -> (t * t) option -end - -(** {5 Coercion functions} *) - -val coerce_to_constr_context : Value.t -> constr - -val coerce_var_to_ident : bool -> Environ.env -> Value.t -> Id.t - -val coerce_to_ident_not_fresh : Evd.evar_map -> Environ.env -> Value.t -> Id.t - -val coerce_to_intro_pattern : Environ.env -> Value.t -> Tacexpr.delayed_open_constr intro_pattern_expr - -val coerce_to_intro_pattern_naming : - Environ.env -> Value.t -> intro_pattern_naming_expr - -val coerce_to_hint_base : Value.t -> string - -val coerce_to_int : Value.t -> int - -val coerce_to_constr : Environ.env -> Value.t -> constr_under_binders - -val coerce_to_uconstr : Environ.env -> Value.t -> Glob_term.closed_glob_constr - -val coerce_to_closed_constr : Environ.env -> Value.t -> constr - -val coerce_to_evaluable_ref : - Environ.env -> Value.t -> evaluable_global_reference - -val coerce_to_constr_list : Environ.env -> Value.t -> constr list - -val coerce_to_intro_pattern_list : - Loc.t -> Environ.env -> Value.t -> Tacexpr.intro_patterns - -val coerce_to_hyp : Environ.env -> Value.t -> Id.t - -val coerce_to_hyp_list : Environ.env -> Value.t -> Id.t list - -val coerce_to_reference : Environ.env -> Value.t -> Globnames.global_reference - -val coerce_to_quantified_hypothesis : Value.t -> quantified_hypothesis - -val coerce_to_decl_or_quant_hyp : Environ.env -> Value.t -> quantified_hypothesis - -val coerce_to_int_or_var_list : Value.t -> int or_var list - -(** {5 Missing generic arguments} *) - -val wit_constr_context : (Empty.t, Empty.t, constr) genarg_type - -val wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) genarg_type diff --git a/ltac/tacentries.ml b/ltac/tacentries.ml deleted file mode 100644 index 2e2b55be7..000000000 --- a/ltac/tacentries.ml +++ /dev/null @@ -1,525 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* entry_name - -(** Quite ad-hoc *) -let get_tacentry n m = - let check_lvl n = - Int.equal m n - && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) - && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) - in - if check_lvl n then EntryName (rawwit Tacarg.wit_tactic, Aself) - else if check_lvl (n + 1) then EntryName (rawwit Tacarg.wit_tactic, Anext) - else EntryName (rawwit Tacarg.wit_tactic, atactic n) - -let get_separator = function -| None -> error "Missing separator." -| Some sep -> sep - -let rec parse_user_entry s sep = - let l = String.length s in - if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then - let entry = parse_user_entry (String.sub s 3 (l-8)) None in - Ulist1 entry - else if l > 12 && coincide s "ne_" 0 && - coincide s "_list_sep" (l-9) then - let entry = parse_user_entry (String.sub s 3 (l-12)) None in - Ulist1sep (entry, get_separator sep) - else if l > 5 && coincide s "_list" (l-5) then - let entry = parse_user_entry (String.sub s 0 (l-5)) None in - Ulist0 entry - else if l > 9 && coincide s "_list_sep" (l-9) then - let entry = parse_user_entry (String.sub s 0 (l-9)) None in - Ulist0sep (entry, get_separator sep) - else if l > 4 && coincide s "_opt" (l-4) then - let entry = parse_user_entry (String.sub s 0 (l-4)) None in - Uopt entry - else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then - let n = Char.code s.[6] - 48 in - Uentryl ("tactic", n) - else - Uentry s - -let arg_list = function Rawwit t -> Rawwit (ListArg t) -let arg_opt = function Rawwit t -> Rawwit (OptArg t) - -let interp_entry_name interp symb = - let rec eval = function - | Ulist1 e -> Ulist1 (eval e) - | Ulist1sep (e, sep) -> Ulist1sep (eval e, sep) - | Ulist0 e -> Ulist0 (eval e) - | Ulist0sep (e, sep) -> Ulist0sep (eval e, sep) - | Uopt e -> Uopt (eval e) - | Uentry s -> Uentry (interp s None) - | Uentryl (s, n) -> Uentryl (interp s (Some n), n) - in - eval symb - -(**********************************************************************) -(** Grammar declaration for Tactic Notation (Coq level) *) - -let get_tactic_entry n = - if Int.equal n 0 then - Pltac.simple_tactic, None - else if Int.equal n 5 then - Pltac.binder_tactic, None - else if 1<=n && n<5 then - Pltac.tactic_expr, Some (Extend.Level (string_of_int n)) - else - error ("Invalid Tactic Notation level: "^(string_of_int n)^".") - -(**********************************************************************) -(** State of the grammar extensions *) - -type tactic_grammar = { - tacgram_level : int; - tacgram_prods : Pptactic.grammar_terminals; -} - -(* Declaration of the tactic grammar rule *) - -let head_is_ident tg = match tg.tacgram_prods with -| TacTerm _ :: _ -> true -| _ -> false - -let rec prod_item_of_symbol lev = function -| Extend.Ulist1 s -> - let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (ListArg typ), Alist1 e) -| Extend.Ulist0 s -> - let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (ListArg typ), Alist0 e) -| Extend.Ulist1sep (s, sep) -> - let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (ListArg typ), Alist1sep (e, Atoken (CLexer.terminal sep))) -| Extend.Ulist0sep (s, sep) -> - let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (ListArg typ), Alist0sep (e, Atoken (CLexer.terminal sep))) -| Extend.Uopt s -> - let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (OptArg typ), Aopt e) -| Extend.Uentry arg -> - let ArgT.Any tag = arg in - let wit = ExtraArg tag in - EntryName (Rawwit wit, Extend.Aentry (genarg_grammar wit)) -| Extend.Uentryl (s, n) -> - let ArgT.Any tag = s in - assert (coincide (ArgT.repr tag) "tactic" 0); - get_tacentry n lev - -(** Tactic grammar extensions *) - -let add_tactic_entry (kn, ml, tg) state = - let open Tacexpr in - let entry, pos = get_tactic_entry tg.tacgram_level in - let mkact loc l = - let map arg = - (** HACK to handle especially the tactic(...) entry *) - let wit = Genarg.rawwit Tacarg.wit_tactic in - if Genarg.has_type arg wit && not ml then - Tacexp (Genarg.out_gen wit arg) - else - TacGeneric arg - in - let l = List.map map l in - (TacAlias (loc,kn,l):raw_tactic_expr) - in - let () = - if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then - error "Notation for simple tactic must start with an identifier." - in - let map = function - | TacTerm s -> GramTerminal s - | TacNonTerm (loc, s, _) -> - let EntryName (typ, e) = prod_item_of_symbol tg.tacgram_level s in - GramNonTerminal (loc, typ, e) - in - let prods = List.map map tg.tacgram_prods in - let rules = make_rule mkact prods in - let r = ExtendRule (entry, None, (pos, [(None, None, [rules])])) in - ([r], state) - -let tactic_grammar = - create_grammar_command "TacticGrammar" add_tactic_entry - -let extend_tactic_grammar kn ml ntn = extend_grammar_command tactic_grammar (kn, ml, ntn) - -(**********************************************************************) -(* Tactic Notation *) - -let entry_names = ref String.Map.empty - -let register_tactic_notation_entry name entry = - let entry = match entry with - | ExtraArg arg -> ArgT.Any arg - | _ -> assert false - in - entry_names := String.Map.add name entry !entry_names - -let interp_prod_item = function - | TacTerm s -> TacTerm s - | TacNonTerm (loc, (nt, sep), id) -> - let symbol = parse_user_entry nt sep in - let interp s = function - | None -> - if String.Map.mem s !entry_names then String.Map.find s !entry_names - else begin match ArgT.name s with - | None -> error ("Unknown entry "^s^".") - | Some arg -> arg - end - | Some n -> - (** FIXME: do better someday *) - assert (String.equal s "tactic"); - begin match Tacarg.wit_tactic with - | ExtraArg tag -> ArgT.Any tag - | _ -> assert false - end - in - let symbol = interp_entry_name interp symbol in - TacNonTerm (loc, symbol, id) - -let make_fresh_key = - let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in - fun prods -> - let cur = incr id; !id in - let map = function - | TacTerm s -> s - | TacNonTerm _ -> "#" - in - let prods = String.concat "_" (List.map map prods) in - (** We embed the hash of the kernel name in the label so that the identifier - should be mostly unique. This ensures that including two modules - together won't confuse the corresponding labels. *) - let hash = (cur lxor (ModPath.hash (Lib.current_mp ()))) land 0x7FFFFFFF in - let lbl = Id.of_string_soft (Printf.sprintf "%s_%08X" prods hash) in - Lib.make_kn lbl - -type tactic_grammar_obj = { - tacobj_key : KerName.t; - tacobj_local : locality_flag; - tacobj_tacgram : tactic_grammar; - tacobj_body : Id.t list * Tacexpr.glob_tactic_expr; - tacobj_forml : bool; -} - -let pprule pa = { - Pptactic.pptac_level = pa.tacgram_level; - pptac_prods = pa.tacgram_prods; -} - -let check_key key = - if Tacenv.check_alias key then - error "Conflicting tactic notations keys. This can happen when including \ - twice the same module." - -let cache_tactic_notation (_, tobj) = - let key = tobj.tacobj_key in - let () = check_key key in - Tacenv.register_alias key tobj.tacobj_body; - extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram; - Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram) - -let open_tactic_notation i (_, tobj) = - let key = tobj.tacobj_key in - if Int.equal i 1 && not tobj.tacobj_local then - extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram - -let load_tactic_notation i (_, tobj) = - let key = tobj.tacobj_key in - let () = check_key key in - (** Only add the printing and interpretation rules. *) - Tacenv.register_alias key tobj.tacobj_body; - Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram); - if Int.equal i 1 && not tobj.tacobj_local then - extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram - -let subst_tactic_notation (subst, tobj) = - let (ids, body) = tobj.tacobj_body in - { tobj with - tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key; - tacobj_body = (ids, Tacsubst.subst_tactic subst body); - } - -let classify_tactic_notation tacobj = Substitute tacobj - -let inTacticGrammar : tactic_grammar_obj -> obj = - declare_object {(default_object "TacticGrammar") with - open_function = open_tactic_notation; - load_function = load_tactic_notation; - cache_function = cache_tactic_notation; - subst_function = subst_tactic_notation; - classify_function = classify_tactic_notation} - -let cons_production_parameter = function -| TacTerm _ -> None -| TacNonTerm (_, _, id) -> Some id - -let add_glob_tactic_notation local n prods forml ids tac = - let parule = { - tacgram_level = n; - tacgram_prods = prods; - } in - let tacobj = { - tacobj_key = make_fresh_key prods; - tacobj_local = local; - tacobj_tacgram = parule; - tacobj_body = (ids, tac); - tacobj_forml = forml; - } in - Lib.add_anonymous_leaf (inTacticGrammar tacobj) - -let add_tactic_notation local n prods e = - let ids = List.map_filter cons_production_parameter prods in - let prods = List.map interp_prod_item prods in - let tac = Tacintern.glob_tactic_env ids (Global.env()) e in - add_glob_tactic_notation local n prods false ids tac - -(**********************************************************************) -(* ML Tactic entries *) - -exception NonEmptyArgument - -(** ML tactic notations whose use can be restricted to an identifier are added - as true Ltac entries. *) -let extend_atomic_tactic name entries = - let open Tacexpr in - let map_prod prods = - let (hd, rem) = match prods with - | TacTerm s :: rem -> (s, rem) - | _ -> assert false (** Not handled by the ML extension syntax *) - in - let empty_value = function - | TacTerm s -> raise NonEmptyArgument - | TacNonTerm (_, symb, _) -> - let EntryName (typ, e) = prod_item_of_symbol 0 symb in - let Genarg.Rawwit wit = typ in - let inj x = TacArg (Loc.ghost, TacGeneric (Genarg.in_gen typ x)) in - let default = epsilon_value inj e in - match default with - | None -> raise NonEmptyArgument - | Some def -> Tacintern.intern_tactic_or_tacarg Tacintern.fully_empty_glob_sign def - in - try Some (hd, List.map empty_value rem) with NonEmptyArgument -> None - in - let entries = List.map map_prod entries in - let add_atomic i args = match args with - | None -> () - | Some (id, args) -> - let args = List.map (fun a -> Tacexp a) args in - let entry = { mltac_name = name; mltac_index = i } in - let body = TacML (Loc.ghost, entry, args) in - Tacenv.register_ltac false false (Names.Id.of_string id) body - in - List.iteri add_atomic entries - -let add_ml_tactic_notation name prods = - let len = List.length prods in - let iter i prods = - let open Tacexpr in - let get_id = function - | TacTerm s -> None - | TacNonTerm (_, _, id) -> Some id - in - let ids = List.map_filter get_id prods in - let entry = { mltac_name = name; mltac_index = len - i - 1 } in - let map id = Reference (Misctypes.ArgVar (Loc.ghost, id)) in - let tac = TacML (Loc.ghost, entry, List.map map ids) in - add_glob_tactic_notation false 0 prods true ids tac - in - List.iteri iter (List.rev prods); - extend_atomic_tactic name prods - -(**********************************************************************) -(** Ltac quotations *) - -let ltac_quotations = ref String.Set.empty - -let create_ltac_quotation name cast (e, l) = - let () = - if String.Set.mem name !ltac_quotations then - failwith ("Ltac quotation " ^ name ^ " already registered") - in - let () = ltac_quotations := String.Set.add name !ltac_quotations in - let entry = match l with - | None -> Aentry e - | Some l -> Aentryl (e, l) - in -(* let level = Some "1" in *) - let level = None in - let assoc = None in - let rule = - Next (Next (Next (Next (Next (Stop, - Atoken (CLexer.terminal name)), - Atoken (CLexer.terminal ":")), - Atoken (CLexer.terminal "(")), - entry), - Atoken (CLexer.terminal ")")) - in - let action _ v _ _ _ loc = cast (loc, v) in - let gram = (level, assoc, [Rule (rule, action)]) in - Pcoq.grammar_extend Pltac.tactic_arg None (None, [gram]) - -(** Command *) - - -type tacdef_kind = - | NewTac of Id.t - | UpdateTac of Nametab.ltac_constant - -let is_defined_tac kn = - try ignore (Tacenv.interp_ltac kn); true with Not_found -> false - -let warn_unusable_identifier = - CWarnings.create ~name:"unusable-identifier" ~category:"parsing" - (fun id -> strbrk "The Ltac name" ++ spc () ++ pr_id id ++ spc () ++ - strbrk "may be unusable because of a conflict with a notation.") - -let register_ltac local tacl = - let map tactic_body = - match tactic_body with - | Tacexpr.TacticDefinition ((loc,id), body) -> - let kn = Lib.make_kn id in - let id_pp = pr_id id in - let () = if is_defined_tac kn then - CErrors.user_err ~loc - (str "There is already an Ltac named " ++ id_pp ++ str".") - in - let is_shadowed = - try - match Pcoq.parse_string Pltac.tactic (Id.to_string id) with - | Tacexpr.TacArg _ -> false - | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *) - with e when CErrors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) - in - let () = if is_shadowed then warn_unusable_identifier id in - NewTac id, body - | Tacexpr.TacticRedefinition (ident, body) -> - let loc = loc_of_reference ident in - let kn = - try Nametab.locate_tactic (snd (qualid_of_reference ident)) - with Not_found -> - CErrors.user_err ~loc - (str "There is no Ltac named " ++ pr_reference ident ++ str ".") - in - UpdateTac kn, body - in - let rfun = List.map map tacl in - let recvars = - let fold accu (op, _) = match op with - | UpdateTac _ -> accu - | NewTac id -> (Lib.make_path id, Lib.make_kn id) :: accu - in - List.fold_left fold [] rfun - in - let ist = Tacintern.make_empty_glob_sign () in - let map (name, body) = - let body = Flags.with_option Tacintern.strict_check (Tacintern.intern_tactic_or_tacarg ist) body in - (name, body) - in - let defs () = - (** Register locally the tactic to handle recursivity. This function affects - the whole environment, so that we transactify it afterwards. *) - let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in - let () = List.iter iter_rec recvars in - List.map map rfun - in - let defs = Future.transactify defs () in - let iter (def, tac) = match def with - | NewTac id -> - Tacenv.register_ltac false local id tac; - Flags.if_verbose Feedback.msg_info (Nameops.pr_id id ++ str " is defined") - | UpdateTac kn -> - Tacenv.redefine_ltac local kn tac; - let name = Nametab.shortest_qualid_of_tactic kn in - Flags.if_verbose Feedback.msg_info (Libnames.pr_qualid name ++ str " is redefined") - in - List.iter iter defs - -(** Queries *) - -let print_ltacs () = - let entries = KNmap.bindings (Tacenv.ltac_entries ()) in - let sort (kn1, _) (kn2, _) = KerName.compare kn1 kn2 in - let entries = List.sort sort entries in - let map (kn, entry) = - let qid = - try Some (Nametab.shortest_qualid_of_tactic kn) - with Not_found -> None - in - match qid with - | None -> None - | Some qid -> Some (qid, entry.Tacenv.tac_body) - in - let entries = List.map_filter map entries in - let pr_entry (qid, body) = - let (l, t) = match body with - | Tacexpr.TacFun (l, t) -> (l, t) - | _ -> ([], body) - in - let pr_ltac_fun_arg = function - | None -> spc () ++ str "_" - | Some id -> spc () ++ pr_id id - in - hov 2 (pr_qualid qid ++ prlist pr_ltac_fun_arg l) - in - Feedback.msg_notice (prlist_with_sep fnl pr_entry entries) - -(** 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 diff --git a/ltac/tacentries.mli b/ltac/tacentries.mli deleted file mode 100644 index 969c118fb..000000000 --- a/ltac/tacentries.mli +++ /dev/null @@ -1,64 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Tacexpr.tacdef_body list -> unit -(** Adds new Ltac definitions to the environment. *) - -(** {5 Tactic Notations} *) - -type 'a grammar_tactic_prod_item_expr = 'a Pptactic.grammar_tactic_prod_item_expr = -| TacTerm of string -| TacNonTerm of Loc.t * 'a * Names.Id.t - -type raw_argument = string * string option -(** An argument type as provided in Tactic notations, i.e. a string like - "ne_foo_list_opt" together with a separator that only makes sense in the - "_sep" cases. *) - -type argument = Genarg.ArgT.any Extend.user_symbol -(** A fully resolved argument type given as an AST with generic arguments on the - leaves. *) - -val add_tactic_notation : - locality_flag -> int -> raw_argument grammar_tactic_prod_item_expr list -> - raw_tactic_expr -> unit -(** [add_tactic_notation local level prods expr] adds a tactic notation in the - environment at level [level] with locality [local] made of the grammar - productions [prods] and returning the body [expr] *) - -val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type -> unit -(** Register an argument under a given entry name for tactic notations. When - translating [raw_argument] into [argument], atomic names will be first - looked up according to names registered through this function and fallback - to finding an argument by name (as in {!Genarg}) if there is none - matching. *) - -val add_ml_tactic_notation : ml_tactic_name -> - argument grammar_tactic_prod_item_expr list list -> unit -(** A low-level variant of {!add_tactic_notation} used by the TACTIC EXTEND - ML-side macro. *) - -(** {5 Tactic Quotations} *) - -val create_ltac_quotation : string -> - ('grm Loc.located -> raw_tactic_arg) -> ('grm Pcoq.Gram.entry * int option) -> unit -(** [create_ltac_quotation name f e] adds a quotation rule to Ltac, that is, - Ltac grammar now accepts arguments of the form ["name" ":" "(" ")"], and - generates an argument using [f] on the entry parsed by [e]. *) - -(** {5 Queries} *) - -val print_ltacs : unit -> unit -(** Display the list of ltac definitions currently available. *) diff --git a/ltac/tacenv.ml b/ltac/tacenv.ml deleted file mode 100644 index e3c2b4ad5..000000000 --- a/ltac/tacenv.ml +++ /dev/null @@ -1,143 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* CErrors.anomaly (str "Unknown tactic alias: " ++ KerName.print key) - -let check_alias key = KNmap.mem key !alias_map - -(** ML tactic extensions (TacML) *) - -type ml_tactic = - Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic - -module MLName = -struct - type t = ml_tactic_name - let compare tac1 tac2 = - let c = String.compare tac1.mltac_tactic tac2.mltac_tactic in - if c = 0 then String.compare tac1.mltac_plugin tac2.mltac_plugin - else c -end - -module MLTacMap = Map.Make(MLName) - -let pr_tacname t = - str t.mltac_plugin ++ str "::" ++ str t.mltac_tactic - -let tac_tab = ref MLTacMap.empty - -let register_ml_tactic ?(overwrite = false) s (t : ml_tactic array) = - let () = - if MLTacMap.mem s !tac_tab then - if overwrite then - tac_tab := MLTacMap.remove s !tac_tab - else - CErrors.anomaly (str "Cannot redeclare tactic " ++ pr_tacname s ++ str ".") - in - tac_tab := MLTacMap.add s t !tac_tab - -let interp_ml_tactic { mltac_name = s; mltac_index = i } = - try - let tacs = MLTacMap.find s !tac_tab in - let () = if Array.length tacs <= i then raise Not_found in - tacs.(i) - with Not_found -> - CErrors.user_err - (str "The tactic " ++ pr_tacname s ++ str " is not installed.") - -(***************************************************************************) -(* Tactic registration *) - -(* Summary and Object declaration *) - -open Nametab -open Libobject - -type ltac_entry = { - tac_for_ml : bool; - tac_body : glob_tactic_expr; - tac_redef : ModPath.t list; -} - -let mactab = - Summary.ref (KNmap.empty : ltac_entry KNmap.t) - ~name:"tactic-definition" - -let ltac_entries () = !mactab - -let interp_ltac r = (KNmap.find r !mactab).tac_body - -let is_ltac_for_ml_tactic r = (KNmap.find r !mactab).tac_for_ml - -let add kn b t = - let entry = { tac_for_ml = b; tac_body = t; tac_redef = [] } in - mactab := KNmap.add kn entry !mactab - -let replace kn path t = - let (path, _, _) = KerName.repr path in - let entry _ e = { e with tac_body = t; tac_redef = path :: e.tac_redef } in - mactab := KNmap.modify kn entry !mactab - -let load_md i ((sp, kn), (local, id, b, t)) = match id with -| None -> - let () = if not local then Nametab.push_tactic (Until i) sp kn in - add kn b t -| Some kn0 -> replace kn0 kn t - -let open_md i ((sp, kn), (local, id, b, t)) = match id with -| None -> - let () = if not local then Nametab.push_tactic (Exactly i) sp kn in - add kn b t -| Some kn0 -> replace kn0 kn t - -let cache_md ((sp, kn), (local, id ,b, t)) = match id with -| None -> - let () = Nametab.push_tactic (Until 1) sp kn in - add kn b t -| Some kn0 -> replace kn0 kn t - -let subst_kind subst id = match id with -| None -> None -| Some kn -> Some (Mod_subst.subst_kn subst kn) - -let subst_md (subst, (local, id, b, t)) = - (local, subst_kind subst id, b, Tacsubst.subst_tactic subst t) - -let classify_md (local, _, _, _ as o) = Substitute o - -let inMD : bool * Nametab.ltac_constant option * bool * glob_tactic_expr -> obj = - declare_object {(default_object "TAC-DEFINITION") with - cache_function = cache_md; - load_function = load_md; - open_function = open_md; - subst_function = subst_md; - classify_function = classify_md} - -let register_ltac for_ml local id tac = - ignore (Lib.add_leaf id (inMD (local, None, for_ml, tac))) - -let redefine_ltac local kn tac = - Lib.add_anonymous_leaf (inMD (local, Some kn, false, tac)) diff --git a/ltac/tacenv.mli b/ltac/tacenv.mli deleted file mode 100644 index 94e14223a..000000000 --- a/ltac/tacenv.mli +++ /dev/null @@ -1,75 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* alias_tactic -> unit -(** Register a tactic alias. *) - -val interp_alias : alias -> alias_tactic -(** Recover the the body of an alias. Raises an anomaly if it does not exist. *) - -val check_alias : alias -> bool -(** Returns [true] if an alias is defined, false otherwise. *) - -(** {5 Coq tactic definitions} *) - -val register_ltac : bool -> bool -> Id.t -> glob_tactic_expr -> unit -(** Register a new Ltac with the given name and body. - - The first boolean indicates whether this is done from ML side, rather than - Coq side. If the second boolean flag is set to true, then this is a local - definition. It also puts the Ltac name in the nametab, so that it can be - used unqualified. *) - -val redefine_ltac : bool -> KerName.t -> glob_tactic_expr -> unit -(** Replace a Ltac with the given name and body. If the boolean flag is set - to true, then this is a local redefinition. *) - -val interp_ltac : KerName.t -> glob_tactic_expr -(** Find a user-defined tactic by name. Raise [Not_found] if it is absent. *) - -val is_ltac_for_ml_tactic : KerName.t -> bool -(** Whether the tactic is defined from ML-side *) - -type ltac_entry = { - tac_for_ml : bool; - (** Whether the tactic is defined from ML-side *) - tac_body : glob_tactic_expr; - (** The current body of the tactic *) - tac_redef : ModPath.t list; - (** List of modules redefining the tactic in reverse chronological order *) -} - -val ltac_entries : unit -> ltac_entry KNmap.t -(** Low-level access to all Ltac entries currently defined. *) - -(** {5 ML tactic extensions} *) - -type ml_tactic = - Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic -(** Type of external tactics, used by [TacML]. *) - -val register_ml_tactic : ?overwrite:bool -> ml_tactic_name -> ml_tactic array -> unit -(** Register an external tactic. *) - -val interp_ml_tactic : ml_tactic_entry -> ml_tactic -(** Get the named tactic. Raises a user error if it does not exist. *) diff --git a/ltac/tacexpr.mli b/ltac/tacexpr.mli deleted file mode 100644 index 9c25a1645..000000000 --- a/ltac/tacexpr.mli +++ /dev/null @@ -1,396 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'r Sigma.t -> ('a, 'r) Sigma.sigma } - -type delayed_open_constr_with_bindings = Term.constr with_bindings delayed_open - -type delayed_open_constr = Term.constr delayed_open - -type intro_pattern = delayed_open_constr intro_pattern_expr located -type intro_patterns = delayed_open_constr intro_pattern_expr located list -type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr located -type intro_pattern_naming = intro_pattern_naming_expr located - -(** Generic expressions for atomic tactics *) - -type 'a gen_atomic_tactic_expr = - (* Basic tactics *) - | TacIntroPattern of evars_flag * 'dtrm intro_pattern_expr located list - | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list * - ('nam * 'dtrm intro_pattern_expr located option) option - | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option - | TacCase of evars_flag * 'trm with_bindings_arg - | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list - | TacMutualCofix of Id.t * (Id.t * 'trm) list - | TacAssert of - bool * 'tacexpr option option * - 'dtrm intro_pattern_expr located option * 'trm - | TacGeneralize of ('trm with_occurrences * Name.t) list - | TacLetTac of Name.t * 'trm * 'nam clause_expr * letin_flag * - intro_pattern_naming_expr located option - - (* Derived basic tactics *) - | TacInductionDestruct of - rec_flag * evars_flag * ('trm,'dtrm,'nam) induction_clause_list - - (* Conversion *) - | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr - | TacChange of 'pat option * 'dtrm * 'nam clause_expr - - (* Equality and inversion *) - | TacRewrite of evars_flag * - (bool * multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * - (* spiwack: using ['dtrm] here is a small hack, may not be - stable by a change in the representation of delayed - terms. Because, in fact, it is the whole "with_bindings" - which is delayed. But because the "t" level for ['dtrm] is - uninterpreted, it works fine here too, and avoid more - disruption of this file. *) - 'tacexpr option - | TacInversion of ('trm,'dtrm,'nam) inversion_strength * quantified_hypothesis - -constraint 'a = < - term:'trm; - dterm: 'dtrm; - pattern:'pat; - constant:'cst; - reference:'ref; - name:'nam; - tacexpr:'tacexpr; - level:'lev -> - -(** Possible arguments of a tactic definition *) - -type 'a gen_tactic_arg = - | TacGeneric of 'lev generic_argument - | ConstrMayEval of ('trm,'cst,'pat) may_eval - | Reference of 'ref - | TacCall of Loc.t * 'ref * - 'a gen_tactic_arg list - | TacFreshId of string or_var list - | Tacexp of 'tacexpr - | TacPretype of 'trm - | TacNumgoals - -constraint 'a = < - term:'trm; - dterm: 'dtrm; - pattern:'pat; - constant:'cst; - reference:'ref; - name:'nam; - tacexpr:'tacexpr; - level:'lev -> - -(** Generic ltac expressions. - 't : terms, 'p : patterns, 'c : constants, 'i : inductive, - 'r : ltac refs, 'n : idents, 'l : levels *) - -and 'a gen_tactic_expr = - | TacAtom of Loc.t * 'a gen_atomic_tactic_expr - | TacThen of - 'a gen_tactic_expr * - 'a gen_tactic_expr - | TacDispatch of - 'a gen_tactic_expr list - | TacExtendTac of - 'a gen_tactic_expr array * - 'a gen_tactic_expr * - 'a gen_tactic_expr array - | TacThens of - 'a gen_tactic_expr * - 'a gen_tactic_expr list - | TacThens3parts of - 'a gen_tactic_expr * - 'a gen_tactic_expr array * - 'a gen_tactic_expr * - 'a gen_tactic_expr array - | TacFirst of 'a gen_tactic_expr list - | TacComplete of 'a gen_tactic_expr - | TacSolve of 'a gen_tactic_expr list - | TacTry of 'a gen_tactic_expr - | TacOr of - 'a gen_tactic_expr * - 'a gen_tactic_expr - | TacOnce of - 'a gen_tactic_expr - | TacExactlyOnce of - 'a gen_tactic_expr - | TacIfThenCatch of - 'a gen_tactic_expr * - 'a gen_tactic_expr * - 'a gen_tactic_expr - | TacOrelse of - 'a gen_tactic_expr * - 'a gen_tactic_expr - | TacDo of int or_var * 'a gen_tactic_expr - | TacTimeout of int or_var * 'a gen_tactic_expr - | TacTime of string option * 'a gen_tactic_expr - | TacRepeat of 'a gen_tactic_expr - | TacProgress of 'a gen_tactic_expr - | TacShowHyps of 'a gen_tactic_expr - | TacAbstract of - 'a gen_tactic_expr * Id.t option - | TacId of 'n message_token list - | TacFail of global_flag * int or_var * 'n message_token list - | TacInfo of 'a gen_tactic_expr - | TacLetIn of rec_flag * - (Id.t located * 'a gen_tactic_arg) list * - 'a gen_tactic_expr - | TacMatch of lazy_flag * - 'a gen_tactic_expr * - ('p,'a gen_tactic_expr) match_rule list - | TacMatchGoal of lazy_flag * direction_flag * - ('p,'a gen_tactic_expr) match_rule list - | TacFun of 'a gen_tactic_fun_ast - | TacArg of 'a gen_tactic_arg located - | TacSelect of goal_selector * 'a gen_tactic_expr - (* For ML extensions *) - | TacML of Loc.t * ml_tactic_entry * 'a gen_tactic_arg list - (* For syntax extensions *) - | TacAlias of Loc.t * KerName.t * 'a gen_tactic_arg list - -constraint 'a = < - term:'t; - dterm: 'dtrm; - pattern:'p; - constant:'c; - reference:'r; - name:'n; - tacexpr:'tacexpr; - level:'l -> - -and 'a gen_tactic_fun_ast = - Id.t option list * 'a gen_tactic_expr - -constraint 'a = < - term:'t; - dterm: 'dtrm; - pattern:'p; - constant:'c; - reference:'r; - name:'n; - tacexpr:'te; - level:'l -> - -(** Globalized tactics *) - -type g_trm = glob_constr_and_expr -type g_pat = glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference and_short_name or_var -type g_ref = ltac_constant located or_var -type g_nam = Id.t located - -type g_dispatch = < - term:g_trm; - dterm:g_trm; - pattern:g_pat; - constant:g_cst; - reference:g_ref; - name:g_nam; - tacexpr:glob_tactic_expr; - level:glevel -> - -and glob_tactic_expr = - g_dispatch gen_tactic_expr - -type glob_atomic_tactic_expr = - g_dispatch gen_atomic_tactic_expr - -type glob_tactic_arg = - g_dispatch gen_tactic_arg - -(** Raw tactics *) - -type r_trm = constr_expr -type r_pat = constr_pattern_expr -type r_cst = reference or_by_notation -type r_ref = reference -type r_nam = Id.t located -type r_lev = rlevel - -type r_dispatch = < - term:r_trm; - dterm:r_trm; - pattern:r_pat; - constant:r_cst; - reference:r_ref; - name:r_nam; - tacexpr:raw_tactic_expr; - level:rlevel -> - -and raw_tactic_expr = - r_dispatch gen_tactic_expr - -type raw_atomic_tactic_expr = - r_dispatch gen_atomic_tactic_expr - -type raw_tactic_arg = - r_dispatch gen_tactic_arg - -(** Interpreted tactics *) - -type t_trm = Term.constr -type t_pat = constr_pattern -type t_cst = evaluable_global_reference -type t_ref = ltac_constant located -type t_nam = Id.t - -type t_dispatch = < - term:t_trm; - dterm:g_trm; - pattern:t_pat; - constant:t_cst; - reference:t_ref; - name:t_nam; - tacexpr:unit; - level:tlevel -> - -type atomic_tactic_expr = - t_dispatch gen_atomic_tactic_expr - -(** Misc *) - -type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen -type glob_red_expr = (g_trm, g_cst, g_pat) red_expr_gen - -(** Traces *) - -type ltac_call_kind = - | LtacMLCall of glob_tactic_expr - | LtacNotationCall of KerName.t - | LtacNameCall of ltac_constant - | LtacAtomCall of glob_atomic_tactic_expr - | LtacVarCall of Id.t * glob_tactic_expr - | LtacConstrInterp of Glob_term.glob_constr * Pretyping.ltac_var_map - -type ltac_trace = (Loc.t * ltac_call_kind) list - -type tacdef_body = - | TacticDefinition of Id.t Loc.located * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) - | TacticRedefinition of reference * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) diff --git a/ltac/tacintern.ml b/ltac/tacintern.ml deleted file mode 100644 index 763e0dc22..000000000 --- a/ltac/tacintern.ml +++ /dev/null @@ -1,812 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Anonymous - | Name id -> Name (intern_ident l ist id) - -let strict_check = ref false - -let adjust_loc loc = if !strict_check then dloc else loc - -(* Globalize a name which must be bound -- actually just check it is bound *) -let intern_hyp ist (loc,id as locid) = - if not !strict_check then - locid - else if find_ident id ist then - (dloc,id) - else - Pretype_errors.error_var_not_found ~loc id - -let intern_or_var f ist = function - | ArgVar locid -> ArgVar (intern_hyp ist locid) - | ArgArg x -> ArgArg (f x) - -let intern_int_or_var = intern_or_var (fun (n : int) -> n) -let intern_string_or_var = intern_or_var (fun (s : string) -> s) - -let intern_global_reference ist = function - | Ident (loc,id) when find_var id ist -> ArgVar (loc,id) - | r -> - let loc,_ as lqid = qualid_of_reference r in - try ArgArg (loc,locate_global_with_alias lqid) - with Not_found -> error_global_not_found (snd lqid) - -let intern_ltac_variable ist = function - | Ident (loc,id) -> - if find_var id ist then - (* A local variable of any type *) - ArgVar (loc,id) - else raise Not_found - | _ -> - raise Not_found - -let intern_constr_reference strict ist = function - | Ident (_,id) as r when not strict && find_hyp id ist -> - GVar (dloc,id), Some (CRef (r,None)) - | Ident (_,id) as r when find_var id ist -> - GVar (dloc,id), if strict then None else Some (CRef (r,None)) - | r -> - let loc,_ as lqid = qualid_of_reference r in - GRef (loc,locate_global_with_alias lqid,None), - if strict then None else Some (CRef (r,None)) - -let intern_move_location ist = function - | MoveAfter id -> MoveAfter (intern_hyp ist id) - | MoveBefore id -> MoveBefore (intern_hyp ist id) - | MoveFirst -> MoveFirst - | MoveLast -> MoveLast - -(* Internalize an isolated reference in position of tactic *) - -let intern_isolated_global_tactic_reference r = - let (loc,qid) = qualid_of_reference r in - TacCall (loc,ArgArg (loc,locate_tactic qid),[]) - -let intern_isolated_tactic_reference strict ist r = - (* An ltac reference *) - try Reference (intern_ltac_variable ist r) - with Not_found -> - (* A global tactic *) - try intern_isolated_global_tactic_reference r - with Not_found -> - (* Tolerance for compatibility, allow not to use "constr:" *) - try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) - with Not_found -> - (* Reference not found *) - error_global_not_found (snd (qualid_of_reference r)) - -(* Internalize an applied tactic reference *) - -let intern_applied_global_tactic_reference r = - let (loc,qid) = qualid_of_reference r in - ArgArg (loc,locate_tactic qid) - -let intern_applied_tactic_reference ist r = - (* An ltac reference *) - try intern_ltac_variable ist r - with Not_found -> - (* A global tactic *) - try intern_applied_global_tactic_reference r - with Not_found -> - (* Reference not found *) - error_global_not_found (snd (qualid_of_reference r)) - -(* Intern a reference parsed in a non-tactic entry *) - -let intern_non_tactic_reference strict ist r = - (* An ltac reference *) - try Reference (intern_ltac_variable ist r) - with Not_found -> - (* A constr reference *) - try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) - with Not_found -> - (* Tolerance for compatibility, allow not to use "ltac:" *) - try intern_isolated_global_tactic_reference r - with Not_found -> - (* By convention, use IntroIdentifier for unbound ident, when not in a def *) - match r with - | Ident (loc,id) when not strict -> - let ipat = in_gen (glbwit wit_intro_pattern) (loc, IntroNaming (IntroIdentifier id)) in - TacGeneric ipat - | _ -> - (* Reference not found *) - error_global_not_found (snd (qualid_of_reference r)) - -let intern_message_token ist = function - | (MsgString _ | MsgInt _ as x) -> x - | MsgIdent id -> MsgIdent (intern_hyp ist id) - -let intern_message ist = List.map (intern_message_token ist) - -let intern_quantified_hypothesis ist = function - | AnonHyp n -> AnonHyp n - | NamedHyp id -> - (* Uncomment to disallow "intros until n" in ltac when n is not bound *) - NamedHyp ((*snd (intern_hyp ist (dloc,*)id(* ))*)) - -let intern_binding_name ist x = - (* We use identifier both for variables and binding names *) - (* Todo: consider the body of the lemma to which the binding refer - and if a term w/o ltac vars, check the name is indeed quantified *) - x - -let intern_constr_gen allow_patvar isarity {ltacvars=lfun; genv=env} c = - let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in - let scope = if isarity then Pretyping.IsType else Pretyping.WithoutTypeConstraint in - let ltacvars = { - Constrintern.ltac_vars = lfun; - ltac_bound = Id.Set.empty; - } in - let c' = - warn (Constrintern.intern_gen scope ~allow_patvar ~ltacvars env) c - in - (c',if !strict_check then None else Some c) - -let intern_constr = intern_constr_gen false false -let intern_type = intern_constr_gen false true - -(* Globalize bindings *) -let intern_binding ist (loc,b,c) = - (loc,intern_binding_name ist b,intern_constr ist c) - -let intern_bindings ist = function - | NoBindings -> NoBindings - | ImplicitBindings l -> ImplicitBindings (List.map (intern_constr ist) l) - | ExplicitBindings l -> ExplicitBindings (List.map (intern_binding ist) l) - -let intern_constr_with_bindings ist (c,bl) = - (intern_constr ist c, intern_bindings ist bl) - -let intern_constr_with_bindings_arg ist (clear,c) = - (clear,intern_constr_with_bindings ist c) - -let rec intern_intro_pattern lf ist = function - | loc, IntroNaming pat -> - loc, IntroNaming (intern_intro_pattern_naming lf ist pat) - | loc, IntroAction pat -> - loc, IntroAction (intern_intro_pattern_action lf ist pat) - | loc, IntroForthcoming _ as x -> x - -and intern_intro_pattern_naming lf ist = function - | IntroIdentifier id -> - IntroIdentifier (intern_ident lf ist id) - | IntroFresh id -> - IntroFresh (intern_ident lf ist id) - | IntroAnonymous as x -> x - -and intern_intro_pattern_action lf ist = function - | IntroOrAndPattern l -> - IntroOrAndPattern (intern_or_and_intro_pattern lf ist l) - | IntroInjection l -> - IntroInjection (List.map (intern_intro_pattern lf ist) l) - | IntroWildcard | IntroRewrite _ as x -> x - | IntroApplyOn (c,pat) -> - IntroApplyOn (intern_constr ist c, intern_intro_pattern lf ist pat) - -and intern_or_and_intro_pattern lf ist = function - | IntroAndPattern l -> - IntroAndPattern (List.map (intern_intro_pattern lf ist) l) - | IntroOrPattern ll -> - IntroOrPattern (List.map (List.map (intern_intro_pattern lf ist)) ll) - -let intern_or_and_intro_pattern_loc lf ist = function - | ArgVar (_,id) as x -> - if find_var id ist then x - else error "Disjunctive/conjunctive introduction pattern expected." - | ArgArg (loc,l) -> ArgArg (loc,intern_or_and_intro_pattern lf ist l) - -let intern_intro_pattern_naming_loc lf ist (loc,pat) = - (loc,intern_intro_pattern_naming lf ist pat) - - (* TODO: catch ltac vars *) -let intern_destruction_arg ist = function - | clear,ElimOnConstr c -> clear,ElimOnConstr (intern_constr_with_bindings ist c) - | clear,ElimOnAnonHyp n as x -> x - | clear,ElimOnIdent (loc,id) -> - if !strict_check then - (* If in a defined tactic, no intros-until *) - match intern_constr ist (CRef (Ident (dloc,id), None)) with - | GVar (loc,id),_ -> clear,ElimOnIdent (loc,id) - | c -> clear,ElimOnConstr (c,NoBindings) - else - clear,ElimOnIdent (loc,id) - -let short_name = function - | AN (Ident (loc,id)) when not !strict_check -> Some (loc,id) - | _ -> None - -let intern_evaluable_global_reference ist r = - let lqid = qualid_of_reference r in - try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true lqid) - with Not_found -> - match r with - | Ident (loc,id) when not !strict_check -> EvalVarRef id - | _ -> error_global_not_found (snd lqid) - -let intern_evaluable_reference_or_by_notation ist = function - | AN r -> intern_evaluable_global_reference ist r - | ByNotation (loc,ntn,sc) -> - evaluable_of_global_reference ist.genv - (Notation.interp_notation_as_global_reference loc - (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) - -(* Globalize a reduction expression *) -let intern_evaluable ist = function - | AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id) - | AN (Ident (loc,id)) when not !strict_check && find_hyp id ist -> - ArgArg (EvalVarRef id, Some (loc,id)) - | r -> - let e = intern_evaluable_reference_or_by_notation ist r in - let na = short_name r in - ArgArg (e,na) - -let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid) - -let intern_flag ist red = - { red with rConst = List.map (intern_evaluable ist) red.rConst } - -let intern_constr_with_occurrences ist (l,c) = (l,intern_constr ist c) - -let intern_constr_pattern ist ~as_type ~ltacvars pc = - let ltacvars = { - Constrintern.ltac_vars = ltacvars; - ltac_bound = Id.Set.empty; - } in - let metas,pat = Constrintern.intern_constr_pattern - ist.genv ~as_type ~ltacvars pc - in - let (glob,_ as c) = intern_constr_gen true false ist pc in - let bound_names = Glob_ops.bound_glob_vars glob in - metas,(bound_names,c,pat) - -let dummy_pat = PRel 0 - -let intern_typed_pattern ist p = - (* we cannot ensure in non strict mode that the pattern is closed *) - (* keeping a constr_expr copy is too complicated and we want anyway to *) - (* type it, so we remember the pattern as a glob_constr only *) - let (glob,_ as c) = intern_constr_gen true false ist p in - let bound_names = Glob_ops.bound_glob_vars glob in - (bound_names,c,dummy_pat) - -let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = - let interp_ref r = - try Inl (intern_evaluable ist r) - with e when Logic.catchable_exception e -> - (* Compatibility. In practice, this means that the code above - is useless. Still the idea of having either an evaluable - ref or a pattern seems interesting, with "head" reduction - in case of an evaluable ref, and "strong" reduction in the - subterm matched when a pattern *) - let loc = loc_of_smart_reference r in - let r = match r with - | AN r -> r - | _ -> Qualid (loc,qualid_of_path (path_of_global (smart_global r))) in - let sign = { Constrintern.ltac_vars = ist.ltacvars; Constrintern.ltac_bound = Id.Set.empty } in - let c = Constrintern.interp_reference sign r in - match c with - | GRef (_,r,None) -> - Inl (ArgArg (evaluable_of_global_reference ist.genv r,None)) - | GVar (_,id) -> - let r = evaluable_of_global_reference ist.genv (VarRef id) in - Inl (ArgArg (r,None)) - | _ -> - let bound_names = Glob_ops.bound_glob_vars c in - Inr (bound_names,(c,None),dummy_pat) in - (l, match p with - | Inl r -> interp_ref r - | Inr (CAppExpl(_,(None,r,None),[])) -> - (* We interpret similarly @ref and ref *) - interp_ref (AN r) - | Inr c -> - Inr (intern_typed_pattern ist c)) - -(* This seems fairly hacky, but it's the first way I've found to get proper - globalization of [unfold]. --adamc *) -let dump_glob_red_expr = function - | Unfold occs -> List.iter (fun (_, r) -> - try - Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) - (Smartlocate.smart_global r) - with e when CErrors.noncritical e -> ()) occs - | Cbv grf | Lazy grf -> - List.iter (fun r -> - try - Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) - (Smartlocate.smart_global r) - with e when CErrors.noncritical e -> ()) grf.rConst - | _ -> () - -let intern_red_expr ist = function - | Unfold l -> Unfold (List.map (intern_unfold ist) l) - | Fold l -> Fold (List.map (intern_constr ist) l) - | Cbv f -> Cbv (intern_flag ist f) - | Cbn f -> Cbn (intern_flag ist f) - | Lazy f -> Lazy (intern_flag ist f) - | Pattern l -> Pattern (List.map (intern_constr_with_occurrences ist) l) - | Simpl (f,o) -> - Simpl (intern_flag ist f, - Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) - | CbvVm o -> CbvVm (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) - | CbvNative o -> CbvNative (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) - | (Red _ | Hnf | ExtraRedExpr _ as r ) -> r - -let intern_in_hyp_as ist lf (id,ipat) = - (intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat) - -let intern_hyp_list ist = List.map (intern_hyp ist) - -let intern_inversion_strength lf ist = function - | NonDepInversion (k,idl,ids) -> - NonDepInversion (k,intern_hyp_list ist idl, - Option.map (intern_or_and_intro_pattern_loc lf ist) ids) - | DepInversion (k,copt,ids) -> - DepInversion (k, Option.map (intern_constr ist) copt, - Option.map (intern_or_and_intro_pattern_loc lf ist) ids) - | InversionUsing (c,idl) -> - InversionUsing (intern_constr ist c, intern_hyp_list ist idl) - -(* Interprets an hypothesis name *) -let intern_hyp_location ist ((occs,id),hl) = - ((Locusops.occurrences_map (List.map (intern_int_or_var ist)) occs, - intern_hyp ist id), hl) - -(* Reads a pattern *) -let intern_pattern ist ?(as_type=false) ltacvars = function - | Subterm (b,ido,pc) -> - let (metas,pc) = intern_constr_pattern ist ~as_type:false ~ltacvars pc in - ido, metas, Subterm (b,ido,pc) - | Term pc -> - let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in - None, metas, Term pc - -let intern_constr_may_eval ist = function - | ConstrEval (r,c) -> ConstrEval (intern_red_expr ist r,intern_constr ist c) - | ConstrContext (locid,c) -> - ConstrContext (intern_hyp ist locid,intern_constr ist c) - | ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c) - | ConstrTerm c -> ConstrTerm (intern_constr ist c) - -let name_cons accu = function -| Anonymous -> accu -| Name id -> Id.Set.add id accu - -let opt_cons accu = function -| None -> accu -| Some id -> Id.Set.add id accu - -(* Reads the hypotheses of a "match goal" rule *) -let rec intern_match_goal_hyps ist ?(as_type=false) lfun = function - | (Hyp ((_,na) as locna,mp))::tl -> - let ido, metas1, pat = intern_pattern ist ~as_type:true lfun mp in - let lfun, metas2, hyps = intern_match_goal_hyps ist lfun tl in - let lfun' = name_cons (opt_cons lfun ido) na in - lfun', metas1@metas2, Hyp (locna,pat)::hyps - | (Def ((_,na) as locna,mv,mp))::tl -> - let ido, metas1, patv = intern_pattern ist ~as_type:false lfun mv in - let ido', metas2, patt = intern_pattern ist ~as_type:true lfun mp in - let lfun, metas3, hyps = intern_match_goal_hyps ist ~as_type lfun tl in - let lfun' = name_cons (opt_cons (opt_cons lfun ido) ido') na in - lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps - | [] -> lfun, [], [] - -(* Utilities *) -let extract_let_names lrc = - let fold accu ((loc, name), _) = - if Id.Set.mem name accu then user_err ~loc - ~hdr:"glob_tactic" (str "This variable is bound several times.") - else Id.Set.add name accu - in - List.fold_left fold Id.Set.empty lrc - -let clause_app f = function - { onhyps=None; concl_occs=nl } -> - { onhyps=None; concl_occs=nl } - | { onhyps=Some l; concl_occs=nl } -> - { onhyps=Some(List.map f l); concl_occs=nl} - -(* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *) -let rec intern_atomic lf ist x = - match (x:raw_atomic_tactic_expr) with - (* Basic tactics *) - | TacIntroPattern (ev,l) -> - TacIntroPattern (ev,List.map (intern_intro_pattern lf ist) l) - | TacApply (a,ev,cb,inhyp) -> - TacApply (a,ev,List.map (intern_constr_with_bindings_arg ist) cb, - Option.map (intern_in_hyp_as ist lf) inhyp) - | TacElim (ev,cb,cbo) -> - TacElim (ev,intern_constr_with_bindings_arg ist cb, - Option.map (intern_constr_with_bindings ist) cbo) - | TacCase (ev,cb) -> TacCase (ev,intern_constr_with_bindings_arg ist cb) - | TacMutualFix (id,n,l) -> - let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in - TacMutualFix (intern_ident lf ist id, n, List.map f l) - | TacMutualCofix (id,l) -> - let f (id,c) = (intern_ident lf ist id,intern_type ist c) in - TacMutualCofix (intern_ident lf ist id, List.map f l) - | TacAssert (b,otac,ipat,c) -> - TacAssert (b,Option.map (Option.map (intern_pure_tactic ist)) otac, - Option.map (intern_intro_pattern lf ist) ipat, - intern_constr_gen false (not (Option.is_empty otac)) ist c) - | TacGeneralize cl -> - TacGeneralize (List.map (fun (c,na) -> - intern_constr_with_occurrences ist c, - intern_name lf ist na) cl) - | TacLetTac (na,c,cls,b,eqpat) -> - let na = intern_name lf ist na in - TacLetTac (na,intern_constr ist c, - (clause_app (intern_hyp_location ist) cls),b, - (Option.map (intern_intro_pattern_naming_loc lf ist) eqpat)) - - (* Derived basic tactics *) - | TacInductionDestruct (ev,isrec,(l,el)) -> - TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats),cls) -> - (intern_destruction_arg ist c, - (Option.map (intern_intro_pattern_naming_loc lf ist) ipato, - Option.map (intern_or_and_intro_pattern_loc lf ist) ipats), - Option.map (clause_app (intern_hyp_location ist)) cls)) l, - Option.map (intern_constr_with_bindings ist) el)) - (* Conversion *) - | TacReduce (r,cl) -> - dump_glob_red_expr r; - TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl) - | TacChange (None,c,cl) -> - let is_onhyps = match cl.onhyps with - | None | Some [] -> true - | _ -> false - in - let is_onconcl = match cl.concl_occs with - | AllOccurrences | NoOccurrences -> true - | _ -> false - in - TacChange (None, - (if is_onhyps && is_onconcl - then intern_type ist c else intern_constr ist c), - clause_app (intern_hyp_location ist) cl) - | TacChange (Some p,c,cl) -> - TacChange (Some (intern_typed_pattern ist p),intern_constr ist c, - clause_app (intern_hyp_location ist) cl) - - (* Equality and inversion *) - | TacRewrite (ev,l,cl,by) -> - TacRewrite - (ev, - List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings_arg ist c)) l, - clause_app (intern_hyp_location ist) cl, - Option.map (intern_pure_tactic ist) by) - | TacInversion (inv,hyp) -> - TacInversion (intern_inversion_strength lf ist inv, - intern_quantified_hypothesis ist hyp) - -and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac) - -and intern_tactic_seq onlytac ist = function - | TacAtom (loc,t) -> - let lf = ref ist.ltacvars in - let t = intern_atomic lf ist t in - !lf, TacAtom (adjust_loc loc, t) - | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun) - | TacLetIn (isrec,l,u) -> - let ltacvars = Id.Set.union (extract_let_names l) ist.ltacvars in - let ist' = { ist with ltacvars } in - let l = List.map (fun (n,b) -> - (n,intern_tacarg !strict_check false (if isrec then ist' else ist) b)) l in - ist.ltacvars, TacLetIn (isrec,l,intern_tactic onlytac ist' u) - - | TacMatchGoal (lz,lr,lmr) -> - ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule onlytac ist ~as_type:true lmr) - | TacMatch (lz,c,lmr) -> - ist.ltacvars, - TacMatch (lz,intern_tactic_or_tacarg ist c,intern_match_rule onlytac ist lmr) - | TacId l -> ist.ltacvars, TacId (intern_message ist l) - | TacFail (g,n,l) -> - ist.ltacvars, TacFail (g,intern_int_or_var ist n,intern_message ist l) - | TacProgress tac -> ist.ltacvars, TacProgress (intern_pure_tactic ist tac) - | TacShowHyps tac -> ist.ltacvars, TacShowHyps (intern_pure_tactic ist tac) - | TacAbstract (tac,s) -> - ist.ltacvars, TacAbstract (intern_pure_tactic ist tac,s) - | TacThen (t1,t2) -> - let lfun', t1 = intern_tactic_seq onlytac ist t1 in - let lfun'', t2 = intern_tactic_seq onlytac { ist with ltacvars = lfun' } t2 in - lfun'', TacThen (t1,t2) - | TacDispatch tl -> - ist.ltacvars , TacDispatch (List.map (intern_pure_tactic ist) tl) - | TacExtendTac (tf,t,tl) -> - ist.ltacvars , - TacExtendTac (Array.map (intern_pure_tactic ist) tf, - intern_pure_tactic ist t, - Array.map (intern_pure_tactic ist) tl) - | TacThens3parts (t1,tf,t2,tl) -> - let lfun', t1 = intern_tactic_seq onlytac ist t1 in - let ist' = { ist with ltacvars = lfun' } in - (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) - lfun', TacThens3parts (t1,Array.map (intern_pure_tactic ist') tf,intern_pure_tactic ist' t2, - Array.map (intern_pure_tactic ist') tl) - | TacThens (t,tl) -> - let lfun', t = intern_tactic_seq true ist t in - let ist' = { ist with ltacvars = lfun' } in - (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) - lfun', TacThens (t, List.map (intern_pure_tactic ist') tl) - | TacDo (n,tac) -> - ist.ltacvars, TacDo (intern_int_or_var ist n,intern_pure_tactic ist tac) - | TacTry tac -> ist.ltacvars, TacTry (intern_pure_tactic ist tac) - | TacInfo tac -> ist.ltacvars, TacInfo (intern_pure_tactic ist tac) - | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_pure_tactic ist tac) - | TacTimeout (n,tac) -> - ist.ltacvars, TacTimeout (intern_int_or_var ist n,intern_tactic onlytac ist tac) - | TacTime (s,tac) -> - ist.ltacvars, TacTime (s,intern_tactic onlytac ist tac) - | TacOr (tac1,tac2) -> - ist.ltacvars, TacOr (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2) - | TacOnce tac -> - ist.ltacvars, TacOnce (intern_pure_tactic ist tac) - | TacExactlyOnce tac -> - ist.ltacvars, TacExactlyOnce (intern_pure_tactic ist tac) - | TacIfThenCatch (tac,tact,tace) -> - ist.ltacvars, - TacIfThenCatch ( - intern_pure_tactic ist tac, - intern_pure_tactic ist tact, - intern_pure_tactic ist tace) - | TacOrelse (tac1,tac2) -> - ist.ltacvars, TacOrelse (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2) - | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l) - | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l) - | TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac) - | TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a - | TacSelect (sel, tac) -> - ist.ltacvars, TacSelect (sel, intern_pure_tactic ist tac) - - (* For extensions *) - | TacAlias (loc,s,l) -> - let l = List.map (intern_tacarg !strict_check false ist) l in - ist.ltacvars, TacAlias (loc,s,l) - | TacML (loc,opn,l) -> - let _ignore = Tacenv.interp_ml_tactic opn in - ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_tacarg !strict_check false ist) l) - -and intern_tactic_as_arg loc onlytac ist a = - match intern_tacarg !strict_check onlytac ist a with - | TacCall _ | Reference _ - | TacGeneric _ as a -> TacArg (loc,a) - | Tacexp a -> a - | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> - if onlytac then error_tactic_expected ~loc else TacArg (loc,a) - -and intern_tactic_or_tacarg ist = intern_tactic false ist - -and intern_pure_tactic ist = intern_tactic true ist - -and intern_tactic_fun ist (var,body) = - let lfun = List.fold_left opt_cons ist.ltacvars var in - (var,intern_tactic_or_tacarg { ist with ltacvars = lfun } body) - -and intern_tacarg strict onlytac ist = function - | Reference r -> intern_non_tactic_reference strict ist r - | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c) - | TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f - | TacCall (loc,f,l) -> - TacCall (loc, - intern_applied_tactic_reference ist f, - List.map (intern_tacarg !strict_check false ist) l) - | TacFreshId x -> TacFreshId (List.map (intern_string_or_var ist) x) - | TacPretype c -> TacPretype (intern_constr ist c) - | TacNumgoals -> TacNumgoals - | Tacexp t -> Tacexp (intern_tactic onlytac ist t) - | TacGeneric arg -> - let arg = intern_genarg ist arg in - TacGeneric arg - -(* Reads the rules of a Match Context or a Match *) -and intern_match_rule onlytac ist ?(as_type=false) = function - | (All tc)::tl -> - All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist ~as_type tl) - | (Pat (rl,mp,tc))::tl -> - let {ltacvars=lfun; genv=env} = ist in - let lfun',metas1,hyps = intern_match_goal_hyps ist ~as_type lfun rl in - let ido,metas2,pat = intern_pattern ist ~as_type lfun mp in - let fold accu x = Id.Set.add x accu in - let ltacvars = List.fold_left fold (opt_cons lfun' ido) metas1 in - let ltacvars = List.fold_left fold ltacvars metas2 in - let ist' = { ist with ltacvars } in - Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist ~as_type tl) - | [] -> [] - -and intern_genarg ist (GenArg (Rawwit wit, x)) = - match wit with - | ListArg wit -> - let map x = - let ans = intern_genarg ist (in_gen (rawwit wit) x) in - out_gen (glbwit wit) ans - in - in_gen (glbwit (wit_list wit)) (List.map map x) - | OptArg wit -> - let ans = match x with - | None -> in_gen (glbwit (wit_opt wit)) None - | Some x -> - let s = out_gen (glbwit wit) (intern_genarg ist (in_gen (rawwit wit) x)) in - in_gen (glbwit (wit_opt wit)) (Some s) - in - ans - | PairArg (wit1, wit2) -> - let p, q = x in - let p = out_gen (glbwit wit1) (intern_genarg ist (in_gen (rawwit wit1) p)) in - let q = out_gen (glbwit wit2) (intern_genarg ist (in_gen (rawwit wit2) q)) in - in_gen (glbwit (wit_pair wit1 wit2)) (p, q) - | ExtraArg s -> - snd (Genintern.generic_intern ist (in_gen (rawwit wit) x)) - -(** Other entry points *) - -let glob_tactic x = - Flags.with_option strict_check - (intern_pure_tactic (make_empty_glob_sign ())) x - -let glob_tactic_env l env x = - let ltacvars = - List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in - Flags.with_option strict_check - (intern_pure_tactic - { ltacvars; genv = env }) - x - -let split_ltac_fun = function - | TacFun (l,t) -> (l,t) - | t -> ([],t) - -let pr_ltac_fun_arg = function - | None -> spc () ++ str "_" - | Some id -> spc () ++ pr_id id - -let print_ltac id = - try - let kn = Nametab.locate_tactic id in - let entries = Tacenv.ltac_entries () in - let tac = KNmap.find kn entries in - let filter mp = - try Some (Nametab.shortest_qualid_of_module mp) - with Not_found -> None - in - let mods = List.map_filter filter tac.Tacenv.tac_redef in - let redefined = match mods with - | [] -> mt () - | mods -> - let redef = prlist_with_sep fnl pr_qualid mods in - fnl () ++ str "Redefined by:" ++ fnl () ++ redef - in - let l,t = split_ltac_fun tac.Tacenv.tac_body in - hv 2 ( - hov 2 (str "Ltac" ++ spc() ++ pr_qualid id ++ - prlist pr_ltac_fun_arg l ++ spc () ++ str ":=") - ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) ++ redefined - with - Not_found -> - user_err ~hdr:"print_ltac" - (pr_qualid id ++ spc() ++ str "is not a user defined tactic.") - -(** Registering *) - -let lift intern = (); fun ist x -> (ist, intern ist x) - -let () = - let intern_intro_pattern ist pat = - let lf = ref Id.Set.empty in - let ans = intern_intro_pattern lf ist pat in - let ist = { ist with ltacvars = !lf } in - (ist, ans) - in - Genintern.register_intern0 wit_intro_pattern intern_intro_pattern - -let () = - let intern_clause ist cl = - let ans = clause_app (intern_hyp_location ist) cl in - (ist, ans) - in - Genintern.register_intern0 wit_clause_dft_concl intern_clause - -let intern_ident' ist id = - let lf = ref Id.Set.empty in - (ist, intern_ident lf ist id) - -let intern_ltac ist tac = - Flags.with_option strict_check (fun () -> intern_pure_tactic ist tac) () - -let () = - Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); - Genintern.register_intern0 wit_ref (lift intern_global_reference); - Genintern.register_intern0 wit_ident intern_ident'; - Genintern.register_intern0 wit_var (lift intern_hyp); - Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg); - Genintern.register_intern0 wit_ltac (lift intern_ltac); - Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis); - Genintern.register_intern0 wit_constr (fun ist c -> (ist,intern_constr ist c)); - Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c)); - Genintern.register_intern0 wit_open_constr (fun ist c -> (ist,intern_constr ist c)); - Genintern.register_intern0 wit_red_expr (lift intern_red_expr); - Genintern.register_intern0 wit_bindings (lift intern_bindings); - Genintern.register_intern0 wit_constr_with_bindings (lift intern_constr_with_bindings); - Genintern.register_intern0 wit_destruction_arg (lift intern_destruction_arg); - () - -(** Substitution for notations containing tactic-in-terms *) - -let notation_subst bindings tac = - let fold id c accu = - let loc = Glob_ops.loc_of_glob_constr (fst c) in - let c = ConstrMayEval (ConstrTerm c) in - ((loc, id), c) :: accu - in - let bindings = Id.Map.fold fold bindings [] in - (** This is theoretically not correct due to potential variable capture, but - Ltac has no true variables so one cannot simply substitute *) - TacLetIn (false, bindings, tac) - -let () = Genintern.register_ntn_subst0 wit_tactic notation_subst diff --git a/ltac/tacintern.mli b/ltac/tacintern.mli deleted file mode 100644 index 71ca354fa..000000000 --- a/ltac/tacintern.mli +++ /dev/null @@ -1,64 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* glob_sign - (** same as [fully_empty_glob_sign], but with [Global.env()] as - environment *) - -(** Main globalization functions *) - -val glob_tactic : raw_tactic_expr -> glob_tactic_expr - -val glob_tactic_env : - Id.t list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr - -(** Low-level variants *) - -val intern_pure_tactic : glob_sign -> raw_tactic_expr -> glob_tactic_expr - -val intern_tactic_or_tacarg : - glob_sign -> raw_tactic_expr -> Tacexpr.glob_tactic_expr - -val intern_constr : glob_sign -> constr_expr -> glob_constr_and_expr - -val intern_constr_with_bindings : - glob_sign -> constr_expr * constr_expr bindings -> - glob_constr_and_expr * glob_constr_and_expr bindings - -val intern_hyp : glob_sign -> Id.t Loc.located -> Id.t Loc.located - -(** Adds a globalization function for extra generic arguments *) - -val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument - -(** printing *) -val print_ltac : Libnames.qualid -> std_ppcmds - -(** Reduction expressions *) - -val intern_red_expr : glob_sign -> raw_red_expr -> glob_red_expr -val dump_glob_red_expr : raw_red_expr -> unit - -(* Hooks *) -val strict_check : bool ref diff --git a/ltac/tacinterp.ml b/ltac/tacinterp.ml deleted file mode 100644 index 32bcdfb6a..000000000 --- a/ltac/tacinterp.ml +++ /dev/null @@ -1,2157 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* a typed_abstract_argument_type -> bool = fun v wit -> - let Val.Dyn (t, _) = v in - let t' = match val_tag wit with - | Val.Base t' -> t' - | _ -> assert false (** not used in this module *) - in - match Val.eq t t' with - | None -> false - | Some Refl -> true - -let prj : type a. a Val.typ -> Val.t -> a option = fun t v -> - let Val.Dyn (t', x) = v in - match Val.eq t t' with - | None -> None - | Some Refl -> Some x - -let in_list tag v = - let tag = match tag with Val.Base tag -> tag | _ -> assert false in - Val.Dyn (Val.typ_list, List.map (fun x -> Val.Dyn (tag, x)) v) -let in_gen wit v = - let t = match val_tag wit with - | Val.Base t -> t - | _ -> assert false (** not used in this module *) - in - Val.Dyn (t, v) -let out_gen wit v = - let t = match val_tag wit with - | Val.Base t -> t - | _ -> assert false (** not used in this module *) - in - match prj t v with None -> assert false | Some x -> x - -let val_tag wit = val_tag (topwit wit) - -let pr_argument_type arg = - let Val.Dyn (tag, _) = arg in - Val.pr tag - -let safe_msgnl s = - Proofview.NonLogical.catch - (Proofview.NonLogical.print_debug (s++fnl())) - (fun _ -> Proofview.NonLogical.print_warning (str "bug in the debugger: an exception is raised while printing debug information"++fnl())) - -type value = Val.t - -(** Abstract application, to print ltac functions *) -type appl = - | UnnamedAppl (** For generic applications: nothing is printed *) - | GlbAppl of (Names.kernel_name * Val.t list) list - (** For calls to global constants, some may alias other. *) -let push_appl appl args = - match appl with - | UnnamedAppl -> UnnamedAppl - | GlbAppl l -> GlbAppl (List.map (fun (h,vs) -> (h,vs@args)) l) -let pr_generic arg = - let Val.Dyn (tag, _) = arg in - str"<" ++ Val.pr tag ++ str ":(" ++ Pptactic.pr_value Pptactic.ltop arg ++ str ")>" -let pr_appl h vs = - Pptactic.pr_ltac_constant h ++ spc () ++ - Pp.prlist_with_sep spc pr_generic vs -let rec name_with_list appl t = - match appl with - | [] -> t - | (h,vs)::l -> Proofview.Trace.name_tactic (fun () -> pr_appl h vs) (name_with_list l t) -let name_if_glob appl t = - match appl with - | UnnamedAppl -> t - | GlbAppl l -> name_with_list l t -let combine_appl appl1 appl2 = - match appl1,appl2 with - | UnnamedAppl,a | a,UnnamedAppl -> a - | GlbAppl l1 , GlbAppl l2 -> GlbAppl (l2@l1) - -(* Values for interpretation *) -type tacvalue = - | VFun of appl*ltac_trace * value Id.Map.t * - Id.t option list * glob_tactic_expr - | VRec of value Id.Map.t ref * glob_tactic_expr - -let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = - let wit = Genarg.create_arg "tacvalue" in - let () = register_val0 wit None in - wit - -let of_tacvalue v = in_gen (topwit wit_tacvalue) v -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)) - | _ -> vle - else vle - -module TacStore = Geninterp.TacStore - -let f_avoid_ids : Id.t list TacStore.field = TacStore.field () -(* ids inherited from the call context (needed to get fresh ids) *) -let f_debug : debug_info TacStore.field = TacStore.field () -let f_trace : ltac_trace TacStore.field = TacStore.field () - -(* Signature for interpretation: val_interp and interpretation functions *) -type interp_sign = Geninterp.interp_sign = { - lfun : value Id.Map.t; - extra : TacStore.t } - -let extract_trace ist = match TacStore.get ist.extra f_trace with -| None -> [] -| Some l -> l - -module Value = struct - - include Taccoerce.Value - - let of_closure ist tac = - let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in - of_tacvalue closure - - let cast_error wit v = - let pr_v = Pptactic.pr_value Pptactic.ltop v in - let Val.Dyn (tag, _) = v in - let tag = Val.pr tag in - user_err (str "Type error: value " ++ pr_v ++ str " is a " ++ tag - ++ str " while type " ++ Val.pr wit ++ str " was expected.") - - let unbox wit v ans = match ans with - | None -> cast_error wit v - | Some x -> x - - let rec prj : type a. a Val.tag -> Val.t -> a = fun tag v -> match tag with - | Val.List tag -> List.map (fun v -> prj tag v) (unbox Val.typ_list v (to_list v)) - | Val.Opt tag -> Option.map (fun v -> prj tag v) (unbox Val.typ_opt v (to_option v)) - | Val.Pair (tag1, tag2) -> - let (x, y) = unbox Val.typ_pair v (to_pair v) in - (prj tag1 x, prj tag2 y) - | Val.Base t -> - let Val.Dyn (t', x) = v in - match Val.eq t t' with - | None -> cast_error t v - | Some Refl -> x - - let rec tag_of_arg : type a b c. (a, b, c) genarg_type -> c Val.tag = fun wit -> match wit with - | ExtraArg _ -> val_tag wit - | ListArg t -> Val.List (tag_of_arg t) - | OptArg t -> Val.Opt (tag_of_arg t) - | PairArg (t1, t2) -> Val.Pair (tag_of_arg t1, tag_of_arg t2) - - let val_cast arg v = prj (tag_of_arg arg) v - - let cast (Topwit wit) v = val_cast wit v - -end - -let print_top_val env v = Pptactic.pr_value Pptactic.ltop v - -let dloc = Loc.ghost - -let catching_error call_trace fail (e, info) = - let inner_trace = - Option.default [] (Exninfo.get info ltac_trace_info) - in - if List.is_empty call_trace && List.is_empty inner_trace then fail (e, info) - else begin - assert (CErrors.noncritical e); (* preserved invariant *) - let new_trace = inner_trace @ call_trace in - let located_exc = (e, Exninfo.add info ltac_trace_info new_trace) in - fail located_exc - end - -let catch_error call_trace f x = - try f x - with e when CErrors.noncritical e -> - let e = CErrors.push e in - catching_error call_trace iraise e - -let catch_error_tac call_trace tac = - Proofview.tclORELSE - tac - (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e)) - -let curr_debug ist = match TacStore.get ist.extra f_debug with -| None -> DebugOff -| Some level -> level - -(** TODO: unify printing of generic Ltac values in case of coercion failure. *) - -(* Displays a value *) -let pr_value env v = - let v = Value.normalize v in - if has_type v (topwit wit_tacvalue) then str "a tactic" - else if has_type v (topwit wit_constr_context) then - let c = out_gen (topwit wit_constr_context) v in - match env with - | Some (env,sigma) -> pr_lconstr_env env sigma c - | _ -> str "a term" - else if has_type v (topwit wit_constr) then - let c = out_gen (topwit wit_constr) v in - match env with - | Some (env,sigma) -> pr_lconstr_env env sigma c - | _ -> str "a term" - else if has_type v (topwit wit_constr_under_binders) then - let c = out_gen (topwit wit_constr_under_binders) v in - match env with - | Some (env,sigma) -> pr_lconstr_under_binders_env env sigma c - | _ -> str "a term" - else - str "a value of type" ++ spc () ++ pr_argument_type v - -let pr_closure env ist body = - let pp_body = Pptactic.pr_glob_tactic env body in - let pr_sep () = fnl () in - let pr_iarg (id, arg) = - let arg = pr_argument_type arg in - hov 0 (pr_id id ++ spc () ++ str ":" ++ spc () ++ arg) - in - let pp_iargs = v 0 (prlist_with_sep pr_sep pr_iarg (Id.Map.bindings ist)) in - pp_body ++ fnl() ++ str "in environment " ++ fnl() ++ pp_iargs - -let pr_inspect env expr result = - let pp_expr = Pptactic.pr_glob_tactic env expr in - let pp_result = - if has_type result (topwit wit_tacvalue) then - match to_tacvalue result with - | VFun (_,_, ist, ul, b) -> - let body = if List.is_empty ul then b else (TacFun (ul, b)) in - str "a closure with body " ++ fnl() ++ pr_closure env ist body - | VRec (ist, body) -> - str "a recursive closure" ++ fnl () ++ pr_closure env !ist body - else - let pp_type = pr_argument_type result in - str "an object of type" ++ spc () ++ pp_type - in - pp_expr ++ fnl() ++ str "this is " ++ pp_result - -(* Transforms an id into a constr if possible, or fails with Not_found *) -let constr_of_id env id = - Term.mkVar (let _ = Environ.lookup_named id env in id) - -(** Generic arguments : table of interpretation functions *) - -(* Some of the code further down depends on the fact that push_trace does not modify sigma (the evar map) *) -let push_trace call ist = match TacStore.get ist.extra f_trace with -| None -> Proofview.tclUNIT [call] -| 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 - | VFun (appl,_,lfun,it,b) -> - let t = if List.is_empty it then b else TacFun (it,b) in - push_trace(loc,LtacVarCall (id,t)) ist >>= fun trace -> - let ans = VFun (appl,trace,lfun,it,b) in - Proofview.tclUNIT (of_tacvalue ans) - | _ -> Proofview.tclUNIT 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)) - | _ -> v - else 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 " ++ pr_id 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 - | VFun _ -> v - | _ -> fail () - else fail () - -let intro_pattern_of_ident id = (Loc.ghost, IntroNaming (IntroIdentifier id)) -let value_of_ident id = - in_gen (topwit wit_intro_pattern) (intro_pattern_of_ident id) - -let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 - -let extend_values_with_bindings (ln,lm) lfun = - let of_cub c = match c with - | [], c -> Value.of_constr c - | _ -> in_gen (topwit wit_constr_under_binders) c - in - (* For compatibility, bound variables are visible only if no other - binding of the same name exists *) - let accu = Id.Map.map value_of_ident ln in - let accu = lfun +++ accu in - Id.Map.fold (fun id c accu -> Id.Map.add id (of_cub c) accu) lm accu - -(***************************************************************************) -(* Evaluation/interpretation *) - -let is_variable env id = - Id.List.mem id (ids_of_named_context (Environ.named_context env)) - -(* Debug reference *) -let debug = ref DebugOff - -(* Sets the debugger mode *) -let set_debug pos = debug := pos - -(* Gives the state of debug *) -let get_debug () = !debug - -let debugging_step ist pp = match curr_debug ist with - | DebugOn lev -> - safe_msgnl (str "Level " ++ int lev ++ str": " ++ pp () ++ fnl()) - | _ -> Proofview.NonLogical.return () - -let debugging_exception_step ist signal_anomaly e pp = - let explain_exc = - if signal_anomaly then explain_logic_error - else explain_logic_error_no_anomaly in - debugging_step ist (fun () -> - pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e) - -let error_ltac_variable loc id env v s = - user_err ~loc (str "Ltac variable " ++ pr_id id ++ - strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ - strbrk "which cannot be coerced to " ++ str s ++ str".") - -(* Raise Not_found if not in interpretation sign *) -let try_interp_ltac_var coerce ist env (loc,id) = - let v = Id.Map.find id ist.lfun in - try coerce v with CannotCoerceTo s -> error_ltac_variable loc id env v s - -let interp_ltac_var coerce ist env locid = - try try_interp_ltac_var coerce ist env locid - with Not_found -> anomaly (str "Detected '" ++ Id.print (snd locid) ++ str "' as ltac var at interning time") - -let interp_ident ist env sigma id = - try try_interp_ltac_var (coerce_var_to_ident false env) ist (Some (env,sigma)) (dloc,id) - with Not_found -> id - -(* Interprets an optional identifier, bound or fresh *) -let interp_name ist env sigma = function - | Anonymous -> Anonymous - | Name id -> Name (interp_ident ist env sigma id) - -let interp_intro_pattern_var loc ist env sigma id = - try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some (env,sigma)) (loc,id) - with Not_found -> IntroNaming (IntroIdentifier id) - -let interp_intro_pattern_naming_var loc ist env sigma id = - try try_interp_ltac_var (coerce_to_intro_pattern_naming env) ist (Some (env,sigma)) (loc,id) - with Not_found -> IntroIdentifier id - -let interp_int ist locid = - try try_interp_ltac_var coerce_to_int ist None locid - with Not_found -> - user_err ~loc:(fst locid) ~hdr:"interp_int" - (str "Unbound variable " ++ pr_id (snd locid) ++ str".") - -let interp_int_or_var ist = function - | ArgVar locid -> interp_int ist locid - | ArgArg n -> n - -let interp_int_or_var_as_list ist = function - | ArgVar (_,id as locid) -> - (try coerce_to_int_or_var_list (Id.Map.find id ist.lfun) - with Not_found | CannotCoerceTo _ -> [ArgArg (interp_int ist locid)]) - | ArgArg n as x -> [x] - -let interp_int_or_var_list ist l = - List.flatten (List.map (interp_int_or_var_as_list ist) l) - -(* Interprets a bound variable (especially an existing hypothesis) *) -let interp_hyp ist env sigma (loc,id as locid) = - (* Look first in lfun for a value coercible to a variable *) - try try_interp_ltac_var (coerce_to_hyp env) ist (Some (env,sigma)) 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)) - -let interp_hyp_list_as_list ist env sigma (loc,id as x) = - try coerce_to_hyp_list env (Id.Map.find id ist.lfun) - with Not_found | CannotCoerceTo _ -> [interp_hyp ist env sigma x] - -let interp_hyp_list ist env sigma l = - List.flatten (List.map (interp_hyp_list_as_list ist env sigma) l) - -let interp_move_location ist env sigma = function - | MoveAfter id -> MoveAfter (interp_hyp ist env sigma id) - | MoveBefore id -> MoveBefore (interp_hyp ist env sigma id) - | MoveFirst -> MoveFirst - | MoveLast -> MoveLast - -let interp_reference ist env sigma = function - | ArgArg (_,r) -> r - | ArgVar (loc, id) -> - try try_interp_ltac_var (coerce_to_reference env) ist (Some (env,sigma)) (loc, id) - with Not_found -> - try - VarRef (get_id (Environ.lookup_named id env)) - with Not_found -> error_global_not_found ~loc (qualid_of_ident id) - -let try_interp_evaluable env (loc, id) = - let v = Environ.lookup_named id env in - match v with - | LocalDef _ -> EvalVarRef id - | _ -> error_not_evaluable (VarRef id) - -let interp_evaluable ist env sigma = function - | ArgArg (r,Some (loc,id)) -> - (* Maybe [id] has been introduced by Intro-like tactics *) - begin - try try_interp_evaluable env (loc, id) - with Not_found -> - match r with - | EvalConstRef _ -> r - | _ -> error_global_not_found ~loc (qualid_of_ident id) - end - | ArgArg (r,None) -> r - | ArgVar (loc, id) -> - try try_interp_ltac_var (coerce_to_evaluable_ref env) ist (Some (env,sigma)) (loc, id) - with Not_found -> - try try_interp_evaluable env (loc, id) - with Not_found -> error_global_not_found ~loc (qualid_of_ident id) - -(* Interprets an hypothesis name *) -let interp_occurrences ist occs = - Locusops.occurrences_map (interp_int_or_var_list ist) occs - -let interp_hyp_location ist env sigma ((occs,id),hl) = - ((interp_occurrences ist occs,interp_hyp ist env sigma id),hl) - -let interp_hyp_location_list_as_list ist env sigma ((occs,id),hl as x) = - match occs,hl with - | AllOccurrences,InHyp -> - List.map (fun id -> ((AllOccurrences,id),InHyp)) - (interp_hyp_list_as_list ist env sigma id) - | _,_ -> [interp_hyp_location ist env sigma x] - -let interp_hyp_location_list ist env sigma l = - List.flatten (List.map (interp_hyp_location_list_as_list ist env sigma) l) - -let interp_clause ist env sigma { onhyps=ol; concl_occs=occs } : clause = - { onhyps=Option.map (interp_hyp_location_list ist env sigma) ol; - concl_occs=interp_occurrences ist occs } - -(* Interpretation of constructions *) - -(* Extract the constr list from lfun *) -let extract_ltac_constr_values ist env = - let fold id v accu = - try - let c = coerce_to_constr env v in - Id.Map.add id c accu - with CannotCoerceTo _ -> accu - in - Id.Map.fold fold ist.lfun Id.Map.empty -(** ppedrot: I have changed the semantics here. Before this patch, closure was - implemented as a list and a variable could be bound several times with - different types, resulting in its possible appearance on both sides. This - could barely be defined as a feature... *) - -(* Extract the identifier list from lfun: join all branches (what to do else?)*) -let rec intropattern_ids (loc,pat) = match pat with - | IntroNaming (IntroIdentifier id) -> [id] - | IntroAction (IntroOrAndPattern (IntroAndPattern l)) -> - List.flatten (List.map intropattern_ids l) - | IntroAction (IntroOrAndPattern (IntroOrPattern ll)) -> - List.flatten (List.map intropattern_ids (List.flatten ll)) - | IntroAction (IntroInjection l) -> - List.flatten (List.map intropattern_ids l) - | IntroAction (IntroApplyOn (c,pat)) -> intropattern_ids pat - | IntroNaming (IntroAnonymous | IntroFresh _) - | IntroAction (IntroWildcard | IntroRewrite _) - | IntroForthcoming _ -> [] - -let extract_ids ids lfun = - 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 - else accu @ intropattern_ids (dloc, ipat) - else accu - in - Id.Map.fold fold lfun [] - -let default_fresh_id = Id.of_string "H" - -let interp_fresh_id ist env sigma l = - let extract_ident ist env sigma id = - try try_interp_ltac_var (coerce_to_ident_not_fresh sigma env) - ist (Some (env,sigma)) (dloc,id) - with Not_found -> id in - let ids = List.map_filter (function ArgVar (_, id) -> Some id | _ -> None) l in - let avoid = match TacStore.get ist.extra f_avoid_ids with - | None -> [] - | Some l -> l - in - let avoid = (extract_ids ids ist.lfun) @ avoid in - let id = - if List.is_empty l then default_fresh_id - else - let s = - String.concat "" (List.map (function - | ArgArg s -> s - | ArgVar (_,id) -> Id.to_string (extract_ident ist env sigma id)) l) in - let s = if CLexer.is_keyword s then s^"0" else s in - Id.of_string s in - Tactics.fresh_id_in_env avoid id env - -(* Extract the uconstr list from lfun *) -let extract_ltac_constr_context ist env = - let open Glob_term in - let add_uconstr id env v map = - try Id.Map.add id (coerce_to_uconstr env v) map - with CannotCoerceTo _ -> map - in - let add_constr id env v map = - try Id.Map.add id (coerce_to_constr env v) map - with CannotCoerceTo _ -> map - in - let add_ident id env v map = - try Id.Map.add id (coerce_var_to_ident false env v) map - with CannotCoerceTo _ -> map - in - let fold id v {idents;typed;untyped} = - let idents = add_ident id env v idents in - let typed = add_constr id env v typed in - let untyped = add_uconstr id env v untyped in - { idents ; typed ; untyped } - in - let empty = { idents = Id.Map.empty ;typed = Id.Map.empty ; untyped = Id.Map.empty } in - Id.Map.fold fold ist.lfun empty - -(** Significantly simpler than [interp_constr], to interpret an - untyped constr, it suffices to adjoin a closure environment. *) -let interp_uconstr ist env = function - | (term,None) -> - { closure = extract_ltac_constr_context ist env ; term } - | (_,Some ce) -> - let ( {typed ; untyped } as closure) = extract_ltac_constr_context ist env in - let ltacvars = { - Constrintern.ltac_vars = Id.(Set.union (Map.domain typed) (Map.domain untyped)); - ltac_bound = Id.Map.domain ist.lfun; - } in - { closure ; term = intern_gen WithoutTypeConstraint ~ltacvars env ce } - -let interp_gen kind ist allow_patvar flags env sigma (c,ce) = - let constrvars = extract_ltac_constr_context ist env in - let vars = { - Pretyping.ltac_constrs = constrvars.typed; - Pretyping.ltac_uconstrs = constrvars.untyped; - Pretyping.ltac_idents = constrvars.idents; - Pretyping.ltac_genargs = ist.lfun; - } in - let c = match ce with - | None -> c - (* If at toplevel (ce<>None), the error can be due to an incorrect - context at globalization time: we retype with the now known - intros/lettac/inversion hypothesis names *) - | Some c -> - let constr_context = - Id.Set.union - (Id.Map.domain constrvars.typed) - (Id.Set.union - (Id.Map.domain constrvars.untyped) - (Id.Map.domain constrvars.idents)) - in - let ltacvars = { - ltac_vars = constr_context; - ltac_bound = Id.Map.domain ist.lfun; - } in - let kind_for_intern = - match kind with OfType _ -> WithoutTypeConstraint | _ -> kind in - intern_gen kind_for_intern ~allow_patvar ~ltacvars env c - in - (* Jason Gross: To avoid unnecessary modifications to tacinterp, as - suggested by Arnaud Spiwack, we run push_trace immediately. We do - this with the kludge of an empty proofview, and rely on the - invariant that running the tactic returned by push_trace does - not modify sigma. *) - let (_, dummy_proofview) = Proofview.init sigma [] in - let (trace,_,_,_) = Proofview.apply env (push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist) dummy_proofview in - let (evd,c) = - catch_error trace (understand_ltac flags env sigma vars kind) c - in - (* spiwack: to avoid unnecessary modifications of tacinterp, as this - function already use effect, I call [run] hoping it doesn't mess - up with any assumption. *) - Proofview.NonLogical.run (db_constr (curr_debug ist) env c); - (evd,c) - -let constr_flags = { - use_typeclasses = true; - solve_unification_constraints = true; - use_hook = Some solve_by_implicit_tactic; - fail_evar = true; - expand_evars = true } - -(* Interprets a constr; expects evars to be solved *) -let interp_constr_gen kind ist env sigma c = - interp_gen kind ist false constr_flags env sigma c - -let interp_constr = interp_constr_gen WithoutTypeConstraint - -let interp_type = interp_constr_gen IsType - -let open_constr_use_classes_flags = { - use_typeclasses = true; - solve_unification_constraints = true; - use_hook = Some solve_by_implicit_tactic; - fail_evar = false; - expand_evars = true } - -let open_constr_no_classes_flags = { - use_typeclasses = false; - solve_unification_constraints = true; - use_hook = Some solve_by_implicit_tactic; - fail_evar = false; - expand_evars = true } - -let pure_open_constr_flags = { - use_typeclasses = false; - solve_unification_constraints = true; - use_hook = None; - fail_evar = false; - expand_evars = false } - -(* Interprets an open constr *) -let interp_open_constr ?(expected_type=WithoutTypeConstraint) ist = - let flags = - if expected_type == WithoutTypeConstraint then open_constr_no_classes_flags - else open_constr_use_classes_flags in - interp_gen expected_type ist false flags - -let interp_pure_open_constr ist = - interp_gen WithoutTypeConstraint ist false pure_open_constr_flags - -let interp_typed_pattern ist env sigma (_,c,_) = - let sigma, c = - interp_gen WithoutTypeConstraint ist true pure_open_constr_flags env sigma c in - pattern_of_constr env sigma c - -(* Interprets a constr expression *) -let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = - let try_expand_ltac_var sigma x = - try match dest_fun x with - | GVar (_,id), _ -> - let v = Id.Map.find id ist.lfun in - sigma, List.map inj_fun (coerce_to_constr_list env v) - | _ -> - raise Not_found - with CannotCoerceTo _ | Not_found -> - (* dest_fun, List.assoc may raise Not_found *) - let sigma, c = interp_fun ist env sigma x in - sigma, [c] in - let sigma, l = List.fold_map try_expand_ltac_var sigma l in - sigma, List.flatten l - -let interp_constr_list ist env sigma c = - interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_constr ist env sigma c - -let interp_open_constr_list = - interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_open_constr - -(* Interprets a reduction expression *) -let interp_unfold ist env sigma (occs,qid) = - (interp_occurrences ist occs,interp_evaluable ist env sigma qid) - -let interp_flag ist env sigma red = - { red with rConst = List.map (interp_evaluable ist env sigma) red.rConst } - -let interp_constr_with_occurrences ist env sigma (occs,c) = - let (sigma,c_interp) = interp_constr ist env sigma c in - sigma , (interp_occurrences ist occs, c_interp) - -let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = - let p = match a with - | Inl (ArgVar (loc,id)) -> - (* This is the encoding of an ltac var supposed to be bound - prioritary to an evaluable reference and otherwise to a constr - (it is an encoding to satisfy the "union" type given to Simpl) *) - let coerce_eval_ref_or_constr x = - try Inl (coerce_to_evaluable_ref env x) - with CannotCoerceTo _ -> - let c = coerce_to_closed_constr env x in - Inr (pattern_of_constr env sigma c) in - (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (loc,id) - with Not_found -> - error_global_not_found ~loc (qualid_of_ident id)) - | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) - | Inr c -> Inr (interp_typed_pattern ist env sigma c) in - interp_occurrences ist occs, p - -let interp_constr_with_occurrences_and_name_as_list = - interp_constr_in_compound_list - (fun c -> ((AllOccurrences,c),Anonymous)) - (function ((occs,c),Anonymous) when occs == AllOccurrences -> c - | _ -> raise Not_found) - (fun ist env sigma (occ_c,na) -> - let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma occ_c in - sigma, (c_interp, - interp_name ist env sigma na)) - -let interp_red_expr ist env sigma = function - | Unfold l -> sigma , Unfold (List.map (interp_unfold ist env sigma) l) - | Fold l -> - let (sigma,l_interp) = interp_constr_list ist env sigma l in - sigma , Fold l_interp - | Cbv f -> sigma , Cbv (interp_flag ist env sigma f) - | Cbn f -> sigma , Cbn (interp_flag ist env sigma f) - | Lazy f -> sigma , Lazy (interp_flag ist env sigma f) - | Pattern l -> - let (sigma,l_interp) = - Evd.MonadR.List.map_right - (fun c sigma -> interp_constr_with_occurrences ist env sigma c) l sigma - in - sigma , Pattern l_interp - | Simpl (f,o) -> - sigma , Simpl (interp_flag ist env sigma f, - Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) - | CbvVm o -> - sigma , CbvVm (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) - | CbvNative o -> - sigma , CbvNative (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) - | (Red _ | Hnf | ExtraRedExpr _ as r) -> sigma , r - -let interp_may_eval f ist env sigma = function - | ConstrEval (r,c) -> - let (sigma,redexp) = interp_red_expr ist env sigma r in - let (sigma,c_interp) = f ist env sigma c in - let (redfun, _) = Redexpr.reduction_of_red_expr env redexp in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (c, sigma, _) = redfun.Reductionops.e_redfun env sigma c_interp in - (Sigma.to_evar_map sigma, c) - | ConstrContext ((loc,s),c) -> - (try - let (sigma,ic) = f ist env sigma c in - let ctxt = coerce_to_constr_context (Id.Map.find s ist.lfun) in - let evdref = ref sigma in - let c = subst_meta [Constr_matching.special_meta,ic] ctxt in - let c = Typing.e_solve_evars env evdref c in - !evdref , c - with - | Not_found -> - user_err ~loc ~hdr:"interp_may_eval" - (str "Unbound context identifier" ++ pr_id s ++ str".")) - | ConstrTypeOf c -> - let (sigma,c_interp) = f ist env sigma c in - Typing.type_of ~refresh:true env sigma c_interp - | ConstrTerm c -> - try - f ist env sigma c - with reraise -> - let reraise = CErrors.push reraise in - (* spiwack: to avoid unnecessary modifications of tacinterp, as this - function already use effect, I call [run] hoping it doesn't mess - up with any assumption. *) - Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> - str"interpretation of term " ++ pr_glob_constr_env env (fst c))); - iraise reraise - -(* Interprets a constr expression possibly to first evaluate *) -let interp_constr_may_eval ist env sigma c = - let (sigma,csr) = - try - interp_may_eval interp_constr ist env sigma c - with reraise -> - let reraise = CErrors.push reraise in - (* spiwack: to avoid unnecessary modifications of tacinterp, as this - function already use effect, I call [run] hoping it doesn't mess - up with any assumption. *) - Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> str"evaluation of term")); - iraise reraise - in - begin - (* spiwack: to avoid unnecessary modifications of tacinterp, as this - function already use effect, I call [run] hoping it doesn't mess - up with any assumption. *) - Proofview.NonLogical.run (db_constr (curr_debug ist) env csr); - sigma , csr - end - -(** TODO: should use dedicated printers *) -let rec message_of_value v = - let v = Value.normalize v in - let open Ftactic in - if has_type v (topwit wit_tacvalue) then - Ftactic.return (str "") - else if has_type v (topwit wit_constr) then - let v = out_gen (topwit wit_constr) v in - Ftactic.nf_enter {enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (project gl) v) end } - else if has_type v (topwit wit_constr_under_binders) then - let c = out_gen (topwit wit_constr_under_binders) v in - Ftactic.nf_enter { enter = begin fun gl -> - Ftactic.return (pr_constr_under_binders_env (pf_env gl) (project gl) c) - end } - else if has_type v (topwit wit_unit) then - Ftactic.return (str "()") - else if has_type v (topwit wit_int) then - Ftactic.return (int (out_gen (topwit wit_int) v)) - else if has_type v (topwit wit_intro_pattern) then - let p = out_gen (topwit wit_intro_pattern) v in - let print env sigma c = pr_constr_env env sigma (fst (Tactics.run_delayed env Evd.empty c)) in - Ftactic.nf_enter { enter = begin fun gl -> - Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (project gl) c) p) - end } - else if has_type v (topwit wit_constr_context) then - let c = out_gen (topwit wit_constr_context) v in - Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (project gl) c) end } - else if has_type v (topwit wit_uconstr) then - let c = out_gen (topwit wit_uconstr) v in - Ftactic.nf_enter { enter = begin fun gl -> - Ftactic.return (pr_closed_glob_env (pf_env gl) - (project gl) c) - end } - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_id id) end } - else match Value.to_list v with - | Some l -> - Ftactic.List.map message_of_value l >>= fun l -> - Ftactic.return (prlist_with_sep spc (fun x -> x) l) - | None -> - let tag = pr_argument_type v in - Ftactic.return (str "<" ++ tag ++ str ">") (** TODO *) - -let interp_message_token ist = function - | MsgString s -> Ftactic.return (str s) - | MsgInt n -> Ftactic.return (int n) - | MsgIdent (loc,id) -> - let v = try Some (Id.Map.find id ist.lfun) with Not_found -> None in - match v with - | None -> Ftactic.lift (Tacticals.New.tclZEROMSG (pr_id id ++ str" not found.")) - | Some v -> message_of_value v - -let interp_message ist l = - let open Ftactic in - Ftactic.List.map (interp_message_token ist) l >>= fun l -> - Ftactic.return (prlist_with_sep spc (fun x -> x) l) - -let rec interp_intro_pattern ist env sigma = function - | loc, IntroAction pat -> - let (sigma,pat) = interp_intro_pattern_action ist env sigma pat in - sigma, (loc, IntroAction pat) - | loc, IntroNaming (IntroIdentifier id) -> - sigma, (loc, interp_intro_pattern_var loc ist env sigma id) - | loc, IntroNaming pat -> - sigma, (loc, IntroNaming (interp_intro_pattern_naming loc ist env sigma pat)) - | loc, IntroForthcoming _ as x -> sigma, x - -and interp_intro_pattern_naming loc ist env sigma = function - | IntroFresh id -> IntroFresh (interp_ident ist env sigma id) - | IntroIdentifier id -> interp_intro_pattern_naming_var loc ist env sigma id - | IntroAnonymous as x -> x - -and interp_intro_pattern_action ist env sigma = function - | IntroOrAndPattern l -> - let (sigma,l) = interp_or_and_intro_pattern ist env sigma l in - sigma, IntroOrAndPattern l - | IntroInjection l -> - let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in - sigma, IntroInjection l - | IntroApplyOn (c,ipat) -> - let c = { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_open_constr ist env sigma c in - Sigma.Unsafe.of_pair (c, sigma) - } in - let sigma,ipat = interp_intro_pattern ist env sigma ipat in - sigma, IntroApplyOn (c,ipat) - | IntroWildcard | IntroRewrite _ as x -> sigma, x - -and interp_or_and_intro_pattern ist env sigma = function - | IntroAndPattern l -> - let sigma, l = List.fold_map (interp_intro_pattern ist env) sigma l in - sigma, IntroAndPattern l - | IntroOrPattern ll -> - let sigma, ll = List.fold_map (interp_intro_pattern_list_as_list ist env) sigma ll in - sigma, IntroOrPattern ll - -and interp_intro_pattern_list_as_list ist env sigma = function - | [loc,IntroNaming (IntroIdentifier id)] as l -> - (try sigma, coerce_to_intro_pattern_list loc env (Id.Map.find id ist.lfun) - with Not_found | CannotCoerceTo _ -> - List.fold_map (interp_intro_pattern ist env) sigma l) - | l -> List.fold_map (interp_intro_pattern ist env) sigma l - -let interp_intro_pattern_naming_option ist env sigma = function - | None -> None - | Some (loc,pat) -> Some (loc, interp_intro_pattern_naming loc ist env sigma pat) - -let interp_or_and_intro_pattern_option ist env sigma = function - | None -> sigma, None - | Some (ArgVar (loc,id)) -> - (match coerce_to_intro_pattern env (Id.Map.find id ist.lfun) with - | IntroAction (IntroOrAndPattern l) -> sigma, Some (loc,l) - | _ -> - user_err ~loc (str "Cannot coerce to a disjunctive/conjunctive pattern.")) - | Some (ArgArg (loc,l)) -> - let sigma,l = interp_or_and_intro_pattern ist env sigma l in - sigma, Some (loc,l) - -let interp_intro_pattern_option ist env sigma = function - | None -> sigma, None - | Some ipat -> - let sigma, ipat = interp_intro_pattern ist env sigma ipat in - sigma, Some ipat - -let interp_in_hyp_as ist env sigma (id,ipat) = - let sigma, ipat = interp_intro_pattern_option ist env sigma ipat in - sigma,(interp_hyp ist env sigma id,ipat) - -let interp_quantified_hypothesis ist = function - | AnonHyp n -> AnonHyp n - | NamedHyp id -> - try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id) - with Not_found -> NamedHyp id - -let interp_binding_name ist = function - | AnonHyp n -> AnonHyp n - | NamedHyp id -> - (* If a name is bound, it has to be a quantified hypothesis *) - (* user has to use other names for variables if these ones clash with *) - (* a name intented to be used as a (non-variable) identifier *) - try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id) - with Not_found -> NamedHyp id - -let interp_declared_or_quantified_hypothesis ist env sigma = function - | AnonHyp n -> AnonHyp n - | NamedHyp id -> - try try_interp_ltac_var - (coerce_to_decl_or_quant_hyp env) ist (Some (env,sigma)) (dloc,id) - with Not_found -> NamedHyp id - -let interp_binding ist env sigma (loc,b,c) = - let sigma, c = interp_open_constr ist env sigma c in - sigma, (loc,interp_binding_name ist b,c) - -let interp_bindings ist env sigma = function -| NoBindings -> - sigma, NoBindings -| ImplicitBindings l -> - let sigma, l = interp_open_constr_list ist env sigma l in - sigma, ImplicitBindings l -| ExplicitBindings l -> - let sigma, l = List.fold_map (interp_binding ist env) sigma l in - sigma, ExplicitBindings l - -let interp_constr_with_bindings ist env sigma (c,bl) = - let sigma, bl = interp_bindings ist env sigma bl in - let sigma, c = interp_open_constr ist env sigma c in - sigma, (c,bl) - -let interp_open_constr_with_bindings ist env sigma (c,bl) = - let sigma, bl = interp_bindings ist env sigma bl in - let sigma, c = interp_open_constr ist env sigma c in - sigma, (c, bl) - -let loc_of_bindings = function -| NoBindings -> Loc.ghost -| ImplicitBindings l -> loc_of_glob_constr (fst (List.last l)) -| ExplicitBindings l -> pi1 (List.last l) - -let interp_open_constr_with_bindings_loc ist ((c,_),bl as cb) = - let loc1 = loc_of_glob_constr c in - let loc2 = loc_of_bindings bl in - let loc = if Loc.is_ghost loc2 then loc1 else Loc.merge loc1 loc2 in - let f = { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_open_constr_with_bindings ist env sigma cb in - Sigma.Unsafe.of_pair (c, sigma) - } in - (loc,f) - -let interp_destruction_arg ist gl arg = - match arg with - | keep,ElimOnConstr c -> - keep,ElimOnConstr { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_constr_with_bindings ist env sigma c in - Sigma.Unsafe.of_pair (c, sigma) - } - | keep,ElimOnAnonHyp n as x -> x - | keep,ElimOnIdent (loc,id) -> - let error () = user_err ~loc - (strbrk "Cannot coerce " ++ pr_id id ++ - strbrk " neither to a quantified hypothesis nor to a term.") - in - let try_cast_id id' = - if Tactics.is_quantified_hypothesis id' gl - then keep,ElimOnIdent (loc,id') - else - (keep, ElimOnConstr { delayed = begin fun env sigma -> - try Sigma.here (constr_of_id env id', NoBindings) sigma - with Not_found -> - user_err ~loc ~hdr:"interp_destruction_arg" ( - pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis.") - end }) - in - 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 - | _, IntroNaming (IntroIdentifier id) -> try_cast_id id - | _ -> error () - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - try_cast_id id - else if has_type v (topwit wit_int) then - keep,ElimOnAnonHyp (out_gen (topwit wit_int) v) - else match Value.to_constr v with - | None -> error () - | Some c -> keep,ElimOnConstr { delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) } - with Not_found -> - (* We were in non strict (interactive) mode *) - if Tactics.is_quantified_hypothesis id gl then - keep,ElimOnIdent (loc,id) - else - let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in - let f = { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma,c) = interp_open_constr ist env sigma c in - Sigma.Unsafe.of_pair ((c,NoBindings), sigma) - } in - keep,ElimOnConstr f - -(* Associates variables with values and gives the remaining variables and - values *) -let head_with_value (lvar,lval) = - let rec head_with_value_rec lacc = function - | ([],[]) -> (lacc,[],[]) - | (vr::tvr,ve::tve) -> - (match vr with - | None -> head_with_value_rec lacc (tvr,tve) - | Some v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve)) - | (vr,[]) -> (lacc,vr,[]) - | ([],ve) -> (lacc,[],ve) - in - head_with_value_rec [] (lvar,lval) - -(** [interp_context ctxt] interprets a context (as in - {!Matching.matching_result}) into a context value of Ltac. *) -let interp_context ctxt = in_gen (topwit wit_constr_context) ctxt - -(* Reads a pattern by substituting vars of lfun *) -let use_types = false - -let eval_pattern lfun ist env sigma (bvars,(glob,_),pat as c) = - if use_types then - (bvars,interp_typed_pattern ist env sigma c) - else - (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) - | Term c -> Term (eval_pattern lfun ist env sigma c) - -(* Reads the hypotheses of a Match Context rule *) -let cons_and_check_name id l = - if Id.List.mem id l then - user_err ~hdr:"read_match_goal_hyps" ( - str "Hypothesis pattern-matching variable " ++ pr_id id ++ - str " used twice in the same pattern.") - else id::l - -let rec read_match_goal_hyps lfun ist env sigma lidh = function - | (Hyp ((loc,na) as locna,mp))::tl -> - let lidh' = name_fold cons_and_check_name na lidh in - Hyp (locna,read_pattern lfun ist env sigma mp):: - (read_match_goal_hyps lfun ist env sigma lidh' tl) - | (Def ((loc,na) as locna,mv,mp))::tl -> - let lidh' = name_fold cons_and_check_name na lidh in - Def (locna,read_pattern lfun ist env sigma mv, read_pattern lfun ist env sigma mp):: - (read_match_goal_hyps lfun ist env sigma lidh' tl) - | [] -> [] - -(* Reads the rules of a Match Context or a Match *) -let rec read_match_rule lfun ist env sigma = function - | (All tc)::tl -> (All tc)::(read_match_rule lfun ist env sigma tl) - | (Pat (rl,mp,tc))::tl -> - Pat (read_match_goal_hyps lfun ist env sigma [] rl, read_pattern lfun ist env sigma mp,tc) - :: read_match_rule lfun ist env sigma tl - | [] -> [] - -let warn_deprecated_info = - CWarnings.create ~name:"deprecated-info-tactical" ~category:"deprecated" - (fun () -> - strbrk "The general \"info\" tactic is currently not working." ++ spc()++ - strbrk "There is an \"Info\" command to replace it." ++fnl () ++ - strbrk "Some specific verbose tactics may also exist, such as info_eauto.") - -(* Interprets an l-tac expression into a value *) -let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftactic.t = - (* The name [appl] of applied top-level Ltac names is ignored in - [value_interp]. It is installed in the second step by a call to - [name_vfun], because it gives more opportunities to detect a - [VFun]. Otherwise a [Ltac t := let x := .. in tac] would never - register its name since it is syntactically a let, not a - function. *) - let value_interp ist = match tac with - | TacFun (it, body) -> - Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, it, body))) - | TacLetIn (true,l,u) -> interp_letrec ist l u - | TacLetIn (false,l,u) -> interp_letin ist l u - | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist lz lr lmr - | TacMatch (lz,c,lmr) -> interp_match ist lz c lmr - | TacArg (loc,a) -> interp_tacarg ist a - | t -> - (** Delayed evaluation *) - Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], t))) - in - let open Ftactic in - Control.check_for_interrupt (); - match curr_debug ist with - | DebugOn lev -> - let eval v = - let ist = { ist with extra = TacStore.set ist.extra f_debug v } in - value_interp ist >>= fun v -> return (name_vfun appl v) - in - Tactic_debug.debug_prompt lev tac eval - | _ -> value_interp ist >>= fun v -> return (name_vfun appl v) - - -and eval_tactic ist tac : unit Proofview.tactic = match tac with - | TacAtom (loc,t) -> - let call = LtacAtomCall t in - push_trace(loc,call) ist >>= fun trace -> - Profile_ltac.do_profile "eval_tactic:2" trace - (catch_error_tac trace (interp_atomic ist t)) - | TacFun _ | TacLetIn _ -> assert false - | TacMatchGoal _ | TacMatch _ -> assert false - | TacId [] -> Proofview.tclLIFT (db_breakpoint (curr_debug ist) []) - | TacId s -> - let msgnl = - let open Ftactic in - interp_message ist s >>= fun msg -> - return (hov 0 msg , hov 0 msg) - in - let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print_info msgnl)) in - let log (msg,_) = Proofview.Trace.log (fun () -> msg) in - let break = Proofview.tclLIFT (db_breakpoint (curr_debug ist) s) in - Ftactic.run msgnl begin fun msgnl -> - print msgnl <*> log msgnl <*> break - end - | TacFail (g,n,s) -> - let msg = interp_message ist s in - let tac l = Tacticals.New.tclFAIL (interp_int_or_var ist n) l in - let tac = - match g with - | TacLocal -> fun l -> Proofview.tclINDEPENDENT (tac l) - | TacGlobal -> tac - in - Ftactic.run msg tac - | TacProgress tac -> Tacticals.New.tclPROGRESS (interp_tactic ist tac) - | TacShowHyps tac -> - Proofview.V82.tactic begin - tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac)) - end - | TacAbstract (tac,ido) -> - Proofview.Goal.nf_enter { enter = begin fun gl -> Tactics.tclABSTRACT - (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist tac) - end } - | TacThen (t1,t) -> - Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t) - | TacDispatch tl -> - Proofview.tclDISPATCH (List.map (interp_tactic ist) tl) - | TacExtendTac (tf,t,tl) -> - Proofview.tclEXTEND (Array.map_to_list (interp_tactic ist) tf) - (interp_tactic ist t) - (Array.map_to_list (interp_tactic ist) tl) - | TacThens (t1,tl) -> Tacticals.New.tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl) - | TacThens3parts (t1,tf,t,tl) -> - Tacticals.New.tclTHENS3PARTS (interp_tactic ist t1) - (Array.map (interp_tactic ist) tf) (interp_tactic ist t) (Array.map (interp_tactic ist) tl) - | TacDo (n,tac) -> Tacticals.New.tclDO (interp_int_or_var ist n) (interp_tactic ist tac) - | TacTimeout (n,tac) -> Tacticals.New.tclTIMEOUT (interp_int_or_var ist n) (interp_tactic ist tac) - | TacTime (s,tac) -> Tacticals.New.tclTIME s (interp_tactic ist tac) - | TacTry tac -> Tacticals.New.tclTRY (interp_tactic ist tac) - | TacRepeat tac -> Tacticals.New.tclREPEAT (interp_tactic ist tac) - | TacOr (tac1,tac2) -> - Tacticals.New.tclOR (interp_tactic ist tac1) (interp_tactic ist tac2) - | TacOnce tac -> - Tacticals.New.tclONCE (interp_tactic ist tac) - | TacExactlyOnce tac -> - Tacticals.New.tclEXACTLY_ONCE (interp_tactic ist tac) - | TacIfThenCatch (t,tt,te) -> - Tacticals.New.tclIFCATCH - (interp_tactic ist t) - (fun () -> interp_tactic ist tt) - (fun () -> interp_tactic ist te) - | TacOrelse (tac1,tac2) -> - Tacticals.New.tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2) - | TacFirst l -> Tacticals.New.tclFIRST (List.map (interp_tactic ist) l) - | TacSolve l -> Tacticals.New.tclSOLVE (List.map (interp_tactic ist) l) - | TacComplete tac -> Tacticals.New.tclCOMPLETE (interp_tactic ist tac) - | TacArg a -> interp_tactic ist (TacArg a) - | TacInfo tac -> - warn_deprecated_info (); - eval_tactic ist tac - | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac) - (* For extensions *) - | TacAlias (loc,s,l) -> - let (ids, body) = Tacenv.interp_alias s in - let (>>=) = Ftactic.bind in - let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in - let tac l = - let addvar x v accu = Id.Map.add x v accu in - let lfun = List.fold_right2 addvar ids l ist.lfun in - Ftactic.lift (push_trace (loc,LtacNotationCall s) ist) >>= fun trace -> - let ist = { - lfun = lfun; - extra = TacStore.set ist.extra f_trace trace; } in - val_interp ist body >>= fun v -> - Ftactic.lift (tactic_of_value ist v) - in - let tac = - Ftactic.with_env interp_vars >>= fun (env, lr) -> - let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in - Proofview.Trace.name_tactic name (tac lr) - (* spiwack: this use of name_tactic is not robust to a - change of implementation of [Ftactic]. In such a situation, - some more elaborate solution will have to be used. *) - in - let tac = - let len1 = List.length ids in - let len2 = List.length l in - if len1 = len2 then tac - else Tacticals.New.tclZEROMSG (str "Arguments length mismatch: \ - expected " ++ int len1 ++ str ", found " ++ int len2) - in - Ftactic.run tac (fun () -> Proofview.tclUNIT ()) - - | TacML (loc,opn,l) -> - push_trace (loc,LtacMLCall tac) ist >>= fun trace -> - let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in - let tac = Tacenv.interp_ml_tactic opn in - let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in - let tac args = - let name () = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in - Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) - in - 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 - | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} body - | v -> Ftactic.return (of_tacvalue v) - else Ftactic.return v - -and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t = - match r with - | ArgVar (loc,id) -> - let v = - try Id.Map.find id ist.lfun - with Not_found -> in_gen (topwit wit_var) id - in - let open Ftactic in - force_vrec ist v >>= begin fun v -> - Ftactic.lift (propagate_trace ist loc id v) >>= fun v -> - if mustbetac then Ftactic.return (coerce_to_tactic loc id v) else Ftactic.return v - end - | ArgArg (loc,r) -> - let ids = extract_ids [] ist.lfun in - let loc_info = ((if Loc.is_ghost loc' then loc else loc'),LtacNameCall r) in - let extra = TacStore.set ist.extra f_avoid_ids ids in - push_trace loc_info ist >>= fun trace -> - 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) - -and interp_tacarg ist arg : Val.t Ftactic.t = - match arg with - | TacGeneric arg -> interp_genarg ist arg - | Reference r -> interp_ltac_reference dloc false ist r - | ConstrMayEval c -> - Ftactic.s_enter { s_enter = begin fun gl -> - let sigma = project gl in - let env = Proofview.Goal.env gl in - let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in - Sigma.Unsafe.of_pair (Ftactic.return (Value.of_constr c_interp), sigma) - end } - | TacCall (loc,r,[]) -> - interp_ltac_reference loc true ist r - | TacCall (loc,f,l) -> - let (>>=) = Ftactic.bind in - interp_ltac_reference loc true ist f >>= fun fv -> - Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs -> - interp_app loc ist fv largs - | TacFreshId l -> - Ftactic.enter { enter = begin fun gl -> - let id = interp_fresh_id ist (pf_env gl) (project gl) l in - Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id))) - end } - | TacPretype c -> - Ftactic.s_enter { s_enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in - let env = Proofview.Goal.env gl in - let c = interp_uconstr ist env c in - let Sigma (c, sigma, p) = (type_uconstr ist c).delayed env sigma in - Sigma (Ftactic.return (Value.of_constr c), sigma, p) - end } - | TacNumgoals -> - Ftactic.lift begin - let open Proofview.Notations in - Proofview.numgoals >>= fun i -> - Proofview.tclUNIT (Value.of_int i) - end - | Tacexp t -> val_interp ist t - -(* Interprets an application node *) -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 - is not a tactic that expects arguments. - Otherwise Ltac goes into an infinite loop (val_interp puts - a VFun back on body, and then interp_app is called again...) *) - | (VFun(appl,trace,olfun,(_::_ as var),body) - |VFun(appl,trace,olfun,([] as var), - (TacFun _|TacLetIn _|TacMatchGoal _|TacMatch _| TacArg _ as body))) -> - let (extfun,lvar,lval)=head_with_value (var,largs) in - let fold accu (id, v) = Id.Map.add id v accu in - let newlfun = List.fold_left fold olfun extfun in - if List.is_empty lvar then - begin Proofview.tclORELSE - begin - let ist = { - lfun = newlfun; - extra = TacStore.set ist.extra f_trace []; } in - catch_error_tac trace (val_interp ist body) >>= fun v -> - Ftactic.return (name_vfun (push_appl appl largs) v) - end - begin fun (e, info) -> - Proofview.tclLIFT (debugging_exception_step ist false e (fun () -> str "evaluation")) <*> - Proofview.tclZERO ~info e - end - end >>= fun v -> - (* No errors happened, we propagate the trace *) - let v = append_trace trace v in - Proofview.tclLIFT begin - debugging_step ist - (fun () -> - str"evaluation returns"++fnl()++pr_value None v) - end <*> - if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval - else - Ftactic.return (of_tacvalue (VFun(push_appl appl largs,trace,newlfun,lvar,body))) - | _ -> fail - else fail - -(* 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) -> - let ist = { - lfun = lfun; - 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 _|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 - tactic_of_value ist tac - else Tacticals.New.tclZEROMSG (str "Expression does not evaluate to a tactic.") - -(* Interprets the clauses of a recursive LetIn *) -and interp_letrec ist llc u = - Proofview.tclUNIT () >>= fun () -> (* delay for the effects of [lref], just in case. *) - let lref = ref ist.lfun in - let fold accu ((_, id), b) = - let v = of_tacvalue (VRec (lref, TacArg (dloc, b))) in - Id.Map.add id v accu - in - let lfun = List.fold_left fold ist.lfun llc in - let () = lref := lfun in - let ist = { ist with lfun } in - val_interp ist u - -(* Interprets the clauses of a LetIn *) -and interp_letin ist llc u = - let rec fold lfun = function - | [] -> - let ist = { ist with lfun } in - val_interp ist u - | ((_, id), body) :: defs -> - Ftactic.bind (interp_tacarg ist body) (fun v -> - fold (Id.Map.add id v lfun) defs) - in - fold ist.lfun llc - -(** [interp_match_success lz ist succ] interprets a single matching success - (of type {!Tactic_matching.t}). *) -and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = - let (>>=) = Ftactic.bind in - let lctxt = Id.Map.map interp_context context in - let hyp_subst = Id.Map.map Value.of_constr terms in - let lfun = extend_values_with_bindings subst (lctxt +++ hyp_subst +++ ist.lfun) in - let ist = { ist with lfun } in - val_interp ist lhs >>= fun v -> - if has_type v (topwit wit_tacvalue) then match to_tacvalue v with - | VFun (appl,trace,lfun,[],t) -> - let ist = { - lfun = lfun; - extra = TacStore.set ist.extra f_trace trace; } in - let tac = eval_tactic ist t in - let dummy = VFun (appl,extract_trace ist, Id.Map.empty, [], TacId []) in - catch_error_tac trace (tac <*> Ftactic.return (of_tacvalue dummy)) - | _ -> Ftactic.return v - else Ftactic.return v - - -(** [interp_match_successes lz ist s] interprets the stream of - matching of successes [s]. If [lz] is set to true, then only the - first success is considered, otherwise further successes are tried - if the left-hand side fails. *) -and interp_match_successes lz ist s = - let general = - let break (e, info) = match e with - | FailError (0, _) -> None - | FailError (n, s) -> Some (FailError (pred n, s), info) - | _ -> None - in - Proofview.tclBREAK break s >>= fun ans -> interp_match_success ist ans - in - match lz with - | General -> - general - | Select -> - begin - (** Only keep the first matching result, we don't backtrack on it *) - let s = Proofview.tclONCE s in - s >>= fun ans -> interp_match_success ist ans - end - | Once -> - (** Once a tactic has succeeded, do not backtrack anymore *) - Proofview.tclONCE general - -(* Interprets the Match expressions *) -and interp_match ist lz constr lmr = - let (>>=) = Ftactic.bind in - begin Proofview.tclORELSE - (interp_ltac_constr ist constr) - begin function - | (e, info) -> - Proofview.tclLIFT (debugging_exception_step ist true e - (fun () -> str "evaluation of the matched expression")) <*> - Proofview.tclZERO ~info e - end - end >>= fun constr -> - Ftactic.enter { enter = begin fun gl -> - let sigma = project gl in - let env = Proofview.Goal.env gl in - let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in - interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr) - end } - -(* Interprets the Match Context expressions *) -and interp_match_goal ist lz lr lmr = - Ftactic.nf_enter { enter = begin fun gl -> - let sigma = project gl in - let env = Proofview.Goal.env gl in - let hyps = Proofview.Goal.hyps gl in - let hyps = if lr then List.rev hyps else hyps in - let concl = Proofview.Goal.concl gl in - let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in - interp_match_successes lz ist (Tactic_matching.match_goal env sigma hyps concl ilr) - end } - -(* Interprets extended tactic generic arguments *) -and interp_genarg ist x : Val.t Ftactic.t = - let open Ftactic.Notations in - (** Ad-hoc handling of some types. *) - let tag = genarg_tag x in - if argument_type_eq tag (unquote (topwit (wit_list wit_var))) then - interp_genarg_var_list ist x - else if argument_type_eq tag (unquote (topwit (wit_list wit_constr))) then - interp_genarg_constr_list ist x - else - let GenArg (Glbwit wit, x) = x in - match wit with - | ListArg wit -> - let map x = interp_genarg ist (Genarg.in_gen (glbwit wit) x) in - Ftactic.List.map map x >>= fun l -> - Ftactic.return (Val.Dyn (Val.typ_list, l)) - | OptArg wit -> - begin match x with - | None -> Ftactic.return (Val.Dyn (Val.typ_opt, None)) - | Some x -> - interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> - Ftactic.return (Val.Dyn (Val.typ_opt, Some x)) - end - | PairArg (wit1, wit2) -> - let (p, q) = x in - interp_genarg ist (Genarg.in_gen (glbwit wit1) p) >>= fun p -> - interp_genarg ist (Genarg.in_gen (glbwit wit2) q) >>= fun q -> - Ftactic.return (Val.Dyn (Val.typ_pair, (p, q))) - | ExtraArg s -> - Geninterp.interp wit ist x - -(** returns [true] for genargs which have the same meaning - independently of goals. *) - -and interp_genarg_constr_list ist x = - Ftactic.nf_s_enter { s_enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in - let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in - let (sigma,lc) = interp_constr_list ist env sigma lc in - let lc = in_list (val_tag wit_constr) lc in - Sigma.Unsafe.of_pair (Ftactic.return lc, sigma) - end } - -and interp_genarg_var_list ist x = - Ftactic.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in - let lc = Genarg.out_gen (glbwit (wit_list wit_var)) x in - let lc = interp_hyp_list ist env sigma lc in - let lc = in_list (val_tag wit_var) lc in - Ftactic.return lc - end } - -(* Interprets tactic expressions : returns a "constr" *) -and interp_ltac_constr ist e : constr Ftactic.t = - let (>>=) = Ftactic.bind in - begin Proofview.tclORELSE - (val_interp ist e) - begin function (err, info) -> match err with - | Not_found -> - Ftactic.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - Proofview.tclLIFT begin - debugging_step ist (fun () -> - str "evaluation failed for" ++ fnl() ++ - Pptactic.pr_glob_tactic env e) - end - <*> Proofview.tclZERO Not_found - end } - | err -> Proofview.tclZERO ~info err - end - end >>= fun result -> - Ftactic.enter { 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 - debugging_step ist (fun () -> - Pptactic.pr_glob_tactic env e ++ fnl() ++ - str " has value " ++ fnl() ++ - pr_constr_env env sigma cresult) - end <*> - Ftactic.return cresult - with CannotCoerceTo _ -> - let env = Proofview.Goal.env gl in - Tacticals.New.tclZEROMSG (str "Must evaluate to a closed term" ++ fnl() ++ - str "offending expression: " ++ fnl() ++ pr_inspect env e result) - end } - - -(* Interprets tactic expressions : returns a "tactic" *) -and interp_tactic ist tac : unit Proofview.tactic = - Ftactic.run (val_interp ist tac) (fun v -> tactic_of_value ist v) - -(* Provides a "name" for the trace to atomic tactics *) -and name_atomic ?env tacexpr tac : unit Proofview.tactic = - begin match env with - | Some e -> Proofview.tclUNIT e - | None -> Proofview.tclENV - end >>= fun env -> - let name () = Pptactic.pr_atomic_tactic env tacexpr in - Proofview.Trace.name_tactic name tac - -(* Interprets a primitive tactic *) -and interp_atomic ist tac : unit Proofview.tactic = - match tac with - (* Basic tactics *) - | TacIntroPattern (ev,l) -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in - Tacticals.New.tclWITHHOLES ev - (name_atomic ~env - (TacIntroPattern (ev,l)) - (* spiwack: print uninterpreted, not sure if it is the - expected behaviour. *) - (Tactics.intro_patterns ev l')) sigma - end } - | TacApply (a,ev,cb,cl) -> - (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let l = List.map (fun (k,c) -> - let loc, f = interp_open_constr_with_bindings_loc ist c in - (k,(loc,f))) cb - in - let sigma,tac = match cl with - | None -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l - | Some cl -> - let sigma,(id,cl) = interp_in_hyp_as ist env sigma cl in - sigma, Tactics.apply_delayed_in a ev id l cl in - Tacticals.New.tclWITHHOLES ev tac sigma - end } - end - | TacElim (ev,(keep,cb),cbo) -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let sigma, cb = interp_constr_with_bindings ist env sigma cb in - let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in - let named_tac = - let tac = Tactics.elim ev keep cb cbo in - name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac - in - Tacticals.New.tclWITHHOLES ev named_tac sigma - end } - | TacCase (ev,(keep,cb)) -> - Proofview.Goal.enter { enter = begin fun gl -> - let sigma = project gl in - let env = Proofview.Goal.env gl in - let sigma, cb = interp_constr_with_bindings ist env sigma cb in - let named_tac = - let tac = Tactics.general_case_analysis ev keep cb in - name_atomic ~env (TacCase(ev,(keep,cb))) tac - in - Tacticals.New.tclWITHHOLES ev named_tac sigma - end } - | TacMutualFix (id,n,l) -> - (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let env = pf_env gl in - let f sigma (id,n,c) = - let (sigma,c_interp) = interp_type ist env sigma c in - sigma , (interp_ident ist env sigma id,n,c_interp) in - let (sigma,l_interp) = - Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) - in - let tac = Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0 in - Sigma.Unsafe.of_pair (tac, sigma) - end } - end - | TacMutualCofix (id,l) -> - (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let env = pf_env gl in - let f sigma (id,c) = - let (sigma,c_interp) = interp_type ist env sigma c in - sigma , (interp_ident ist env sigma id,c_interp) in - let (sigma,l_interp) = - Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) - in - let tac = Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0 in - Sigma.Unsafe.of_pair (tac, sigma) - end } - end - | TacAssert (b,t,ipat,c) -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let (sigma,c) = - (if Option.is_empty t then interp_constr else interp_type) ist env sigma c - in - let sigma, ipat' = interp_intro_pattern_option ist env sigma ipat in - let tac = Option.map (Option.map (interp_tactic ist)) t in - Tacticals.New.tclWITHHOLES false - (name_atomic ~env - (TacAssert(b,Option.map (Option.map ignore) t,ipat,c)) - (Tactics.forward b tac ipat' c)) sigma - end } - | TacGeneralize cl -> - Proofview.Goal.enter { enter = begin fun gl -> - let sigma = project gl in - let env = Proofview.Goal.env gl in - let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in - Tacticals.New.tclWITHHOLES false - (name_atomic ~env - (TacGeneralize cl) - (Tactics.generalize_gen cl)) sigma - end } - | TacLetTac (na,c,clp,b,eqpat) -> - Proofview.V82.nf_evar_goals <*> - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let clp = interp_clause ist env sigma clp in - let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in - if Locusops.is_nowhere clp then - (* We try to fully-typecheck the term *) - let (sigma,c_interp) = interp_constr ist env sigma c in - let let_tac b na c cl eqpat = - let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in - let with_eq = if b then None else Some (true,id) in - Tactics.letin_tac with_eq na c None cl - in - let na = interp_name ist env sigma na in - Tacticals.New.tclWITHHOLES false - (name_atomic ~env - (TacLetTac(na,c_interp,clp,b,eqpat)) - (let_tac b na c_interp clp eqpat)) sigma - else - (* We try to keep the pattern structure as much as possible *) - let let_pat_tac b na c cl eqpat = - let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in - let with_eq = if b then None else Some (true,id) in - Tactics.letin_pat_tac with_eq na c cl - in - let (sigma',c) = interp_pure_open_constr ist env sigma c in - name_atomic ~env - (TacLetTac(na,c,clp,b,eqpat)) - (Tacticals.New.tclWITHHOLES false (*in hope of a future "eset/epose"*) - (let_pat_tac b (interp_name ist env sigma na) - ((sigma,sigma'),c) clp eqpat) sigma') - end } - - (* Derived basic tactics *) - | TacInductionDestruct (isrec,ev,(l,el)) -> - (* spiwack: some unknown part of destruct needs the goal to be - prenormalised. *) - Proofview.V82.nf_evar_goals <*> - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let sigma,l = - List.fold_map begin fun sigma (c,(ipato,ipats),cls) -> - (* TODO: move sigma as a side-effect *) - (* spiwack: the [*p] variants are for printing *) - let cp = c in - let c = interp_destruction_arg ist gl c in - let ipato = interp_intro_pattern_naming_option ist env sigma ipato in - let ipatsp = ipats in - let sigma,ipats = interp_or_and_intro_pattern_option ist env sigma ipats in - let cls = Option.map (interp_clause ist env sigma) cls in - sigma,((c,(ipato,ipats),cls),(cp,(ipato,ipatsp),cls)) - end sigma l - in - let l,lp = List.split l in - let sigma,el = - Option.fold_map (interp_constr_with_bindings ist env) sigma el in - let tac = name_atomic ~env - (TacInductionDestruct(isrec,ev,(lp,el))) - (Tactics.induction_destruct isrec ev (l,el)) - in - Sigma.Unsafe.of_pair (tac, sigma) - end } - - (* Conversion *) - | TacReduce (r,cl) -> - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in - Sigma.Unsafe.of_pair (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl), sigma) - end } - | TacChange (None,c,cl) -> - (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.V82.nf_evar_goals <*> - Proofview.Goal.nf_enter { enter = begin fun gl -> - let is_onhyps = match cl.onhyps with - | None | Some [] -> true - | _ -> false - in - let is_onconcl = match cl.concl_occs with - | AllOccurrences | NoOccurrences -> true - | _ -> false - in - let c_interp patvars = { Sigma.run = begin fun sigma -> - let lfun' = Id.Map.fold (fun id c lfun -> - Id.Map.add id (Value.of_constr c) lfun) - patvars ist.lfun - in - let sigma = Sigma.to_evar_map sigma in - let ist = { ist with lfun = lfun' } in - let (sigma, c) = - if is_onhyps && is_onconcl - then interp_type ist (pf_env gl) sigma c - else interp_constr ist (pf_env gl) sigma c - in - Sigma.Unsafe.of_pair (c, sigma) - end } in - Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl) - end } - end - | TacChange (Some op,c,cl) -> - (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.V82.nf_evar_goals <*> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let op = interp_typed_pattern ist env sigma op in - let to_catch = function Not_found -> true | e -> CErrors.is_anomaly e in - let c_interp patvars = { Sigma.run = begin fun sigma -> - let lfun' = Id.Map.fold (fun id c lfun -> - Id.Map.add id (Value.of_constr c) lfun) - patvars ist.lfun - in - let ist = { ist with lfun = lfun' } in - try - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_constr ist env sigma c in - Sigma.Unsafe.of_pair (c, sigma) - with e when to_catch e (* Hack *) -> - user_err (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") - end } in - Tactics.change (Some op) c_interp (interp_clause ist env sigma cl) - end } - end - - - (* Equality and inversion *) - | TacRewrite (ev,l,cl,by) -> - Proofview.Goal.enter { enter = begin fun gl -> - let l' = List.map (fun (b,m,(keep,c)) -> - let f = { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_open_constr_with_bindings ist env sigma c in - Sigma.Unsafe.of_pair (c, sigma) - } in - (b,m,keep,f)) l in - let env = Proofview.Goal.env gl in - let sigma = project gl in - let cl = interp_clause ist env sigma cl in - name_atomic ~env - (TacRewrite (ev,l,cl,Option.map ignore by)) - (Equality.general_multi_rewrite ev l' cl - (Option.map (fun by -> Tacticals.New.tclCOMPLETE (interp_tactic ist by), - Equality.Naive) - by)) - end } - | TacInversion (DepInversion (k,c,ids),hyp) -> - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let (sigma,c_interp) = - match c with - | None -> sigma , None - | Some c -> - let (sigma,c_interp) = interp_constr ist env sigma c in - sigma , Some c_interp - in - let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in - let sigma,ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in - Tacticals.New.tclWITHHOLES false - (name_atomic ~env - (TacInversion(DepInversion(k,c_interp,ids),dqhyps)) - (Inv.dinv k c_interp ids_interp dqhyps)) sigma - end } - | TacInversion (NonDepInversion (k,idl,ids),hyp) -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let hyps = interp_hyp_list ist env sigma idl in - let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in - let sigma, ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in - Tacticals.New.tclWITHHOLES false - (name_atomic ~env - (TacInversion (NonDepInversion (k,hyps,ids),dqhyps)) - (Inv.inv_clause k ids_interp hyps dqhyps)) sigma - end } - | TacInversion (InversionUsing (c,idl),hyp) -> - Proofview.Goal.s_enter { s_enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let (sigma,c_interp) = interp_constr ist env sigma c in - let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in - let hyps = interp_hyp_list ist env sigma idl in - let tac = name_atomic ~env - (TacInversion (InversionUsing (c_interp,hyps),dqhyps)) - (Leminv.lemInv_clause dqhyps c_interp hyps) - in - Sigma.Unsafe.of_pair (tac, sigma) - end } - -(* Initial call for interpretation *) - -let default_ist () = - let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in - { lfun = Id.Map.empty; extra = extra } - -let eval_tactic t = - Proofview.tclUNIT () >>= fun () -> (* delay for [default_ist] *) - Proofview.tclLIFT db_initialize <*> - interp_tactic (default_ist ()) t - -let eval_tactic_ist ist t = - Proofview.tclLIFT db_initialize <*> - interp_tactic ist t - -(* globalization + interpretation *) - - -let interp_tac_gen lfun avoid_ids debug t = - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let extra = TacStore.set TacStore.empty f_debug debug in - let extra = TacStore.set extra f_avoid_ids avoid_ids in - let ist = { lfun = lfun; extra = extra } in - let ltacvars = Id.Map.domain lfun in - interp_tactic ist - (intern_pure_tactic { - ltacvars; genv = env } t) - end } - -let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t - -(* Used to hide interpretation for pretty-print, now just launch tactics *) -(* [global] means that [t] should be internalized outside of goals. *) -let hide_interp global t ot = - let hide_interp env = - let ist = { ltacvars = Id.Set.empty; genv = env } in - let te = intern_pure_tactic ist t in - let t = eval_tactic te in - match ot with - | None -> t - | Some t' -> Tacticals.New.tclTHEN t t' - in - if global then - Proofview.tclENV >>= fun env -> - hide_interp env - else - Proofview.Goal.enter { enter = begin fun gl -> - hide_interp (Proofview.Goal.env gl) - end } - -(***************************************************************************) -(** Register standard arguments *) - -let register_interp0 wit f = - let open Ftactic.Notations in - let interp ist v = - f ist v >>= fun v -> Ftactic.return (Val.inject (val_tag wit) v) - in - Geninterp.register_interp0 wit interp - -let def_intern ist x = (ist, x) -let def_subst _ x = x -let def_interp ist x = Ftactic.return x - -let declare_uniform t = - Genintern.register_intern0 t def_intern; - Genintern.register_subst0 t def_subst; - register_interp0 t def_interp - -let () = - declare_uniform wit_unit - -let () = - declare_uniform wit_int - -let () = - declare_uniform wit_bool - -let () = - declare_uniform wit_string - -let () = - declare_uniform wit_pre_ident - -let lift f = (); fun ist x -> Ftactic.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in - Ftactic.return (f ist env sigma x) -end } - -let lifts f = (); fun ist x -> Ftactic.nf_s_enter { s_enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in - let (sigma, v) = f ist env sigma x in - Sigma.Unsafe.of_pair (Ftactic.return v, sigma) -end } - -let interp_bindings' ist bl = Ftactic.return { delayed = fun env sigma -> - let (sigma, bl) = interp_bindings ist env (Sigma.to_evar_map sigma) bl in - Sigma.Unsafe.of_pair (bl, sigma) - } - -let interp_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigma -> - let (sigma, c) = interp_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in - Sigma.Unsafe.of_pair (c, sigma) - } - -let interp_destruction_arg' ist c = Ftactic.nf_enter { enter = begin fun gl -> - Ftactic.return (interp_destruction_arg ist gl c) -end } - -let () = - register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); - register_interp0 wit_ref (lift interp_reference); - register_interp0 wit_ident (lift interp_ident); - register_interp0 wit_var (lift interp_hyp); - register_interp0 wit_intro_pattern (lifts interp_intro_pattern); - register_interp0 wit_clause_dft_concl (lift interp_clause); - register_interp0 wit_constr (lifts interp_constr); - register_interp0 wit_tacvalue (fun ist v -> Ftactic.return v); - register_interp0 wit_red_expr (lifts interp_red_expr); - register_interp0 wit_quant_hyp (lift interp_declared_or_quantified_hypothesis); - register_interp0 wit_open_constr (lifts interp_open_constr); - register_interp0 wit_bindings interp_bindings'; - register_interp0 wit_constr_with_bindings interp_constr_with_bindings'; - register_interp0 wit_destruction_arg interp_destruction_arg'; - () - -let () = - let interp ist tac = Ftactic.return (Value.of_closure ist tac) in - register_interp0 wit_tactic interp - -let () = - let interp ist tac = interp_tactic ist tac >>= fun () -> Ftactic.return () in - register_interp0 wit_ltac interp - -let () = - register_interp0 wit_uconstr (fun ist c -> Ftactic.nf_enter { enter = begin fun gl -> - Ftactic.return (interp_uconstr ist (Proofview.Goal.env gl) c) - end }) - -(***************************************************************************) -(* Other entry points *) - -let val_interp ist tac k = Ftactic.run (val_interp ist tac) k - -let interp_ltac_constr ist c k = Ftactic.run (interp_ltac_constr ist c) k - -let interp_redexp env sigma r = - let ist = default_ist () in - let gist = { fully_empty_glob_sign with genv = env; } in - interp_red_expr ist env sigma (intern_red_expr gist r) - -(***************************************************************************) -(* Backwarding recursive needs of tactic glob/interp/eval functions *) - -let _ = - let eval ty env sigma lfun arg = - let ist = { lfun = lfun; extra = TacStore.empty; } in - if Genarg.has_type arg (glbwit wit_tactic) then - let tac = Genarg.out_gen (glbwit wit_tactic) arg in - let tac = interp_tactic ist tac in - Pfedit.refine_by_tactic env sigma ty tac - else - failwith "not a tactic" - in - Hook.set Pretyping.genarg_interp_hook eval - -(** Used in tactic extension **) - -let dummy_id = Id.of_string "_" - -let lift_constr_tac_to_ml_tac vars tac = - let tac _ ist = Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let map = function - | None -> None - | Some id -> - let c = Id.Map.find id ist.lfun in - try Some (coerce_to_closed_constr env c) - with CannotCoerceTo ty -> - error_ltac_variable Loc.ghost dummy_id (Some (env,sigma)) c ty - in - let args = List.map_filter map vars in - tac args ist - end } in - tac - -let vernac_debug b = - set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) - -let _ = - let open Goptions in - declare_bool_option - { optsync = false; - optdepr = false; - optname = "Ltac debug"; - optkey = ["Ltac";"Debug"]; - optread = (fun () -> get_debug () != Tactic_debug.DebugOff); - optwrite = vernac_debug } - -let _ = - let open Goptions in - declare_bool_option - { optsync = false; - optdepr = false; - optname = "Ltac debug"; - optkey = ["Debug";"Ltac"]; - optread = (fun () -> get_debug () != Tactic_debug.DebugOff); - optwrite = vernac_debug } - -let () = Hook.set Vernacentries.interp_redexp_hook interp_redexp diff --git a/ltac/tacinterp.mli b/ltac/tacinterp.mli deleted file mode 100644 index 6f64981ef..000000000 --- a/ltac/tacinterp.mli +++ /dev/null @@ -1,122 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t - val to_constr : t -> constr option - val of_int : int -> t - val to_int : t -> int option - val to_list : t -> t list option - val of_closure : Geninterp.interp_sign -> glob_tactic_expr -> t - val cast : 'a typed_abstract_argument_type -> Geninterp.Val.t -> 'a -end - -(** Values for interpretation *) -type value = Value.t - -module TacStore : Store.S with - type t = Geninterp.TacStore.t - and type 'a field = 'a Geninterp.TacStore.field - -(** Signature for interpretation: val\_interp and interpretation functions *) -type interp_sign = Geninterp.interp_sign = { - lfun : value Id.Map.t; - extra : TacStore.t } - -val f_avoid_ids : Id.t list TacStore.field -val f_debug : debug_info TacStore.field - -val extract_ltac_constr_values : interp_sign -> Environ.env -> - Pattern.constr_under_binders Id.Map.t -(** Given an interpretation signature, extract all values which are coercible to - a [constr]. *) - -(** Sets the debugger mode *) -val set_debug : debug_info -> unit - -(** Gives the state of debug *) -val get_debug : unit -> debug_info - -(** Adds an interpretation function for extra generic arguments *) - -val interp_genarg : interp_sign -> glob_generic_argument -> Value.t Ftactic.t - -(** Interprets any expression *) -val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tactic) -> unit Proofview.tactic - -(** Interprets an expression that evaluates to a constr *) -val interp_ltac_constr : interp_sign -> glob_tactic_expr -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic - -(** Interprets redexp arguments *) -val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr - -(** Interprets tactic expressions *) - -val interp_hyp : interp_sign -> Environ.env -> Evd.evar_map -> - Id.t Loc.located -> Id.t - -val interp_constr_gen : Pretyping.typing_constraint -> interp_sign -> - Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Evd.evar_map * constr - -val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> - glob_constr_and_expr bindings -> Evd.evar_map * constr bindings - -val interp_open_constr_with_bindings : interp_sign -> Environ.env -> Evd.evar_map -> - glob_constr_and_expr with_bindings -> Evd.evar_map * constr with_bindings - -(** Initial call for interpretation *) - -val eval_tactic : glob_tactic_expr -> unit Proofview.tactic - -val eval_tactic_ist : interp_sign -> glob_tactic_expr -> unit Proofview.tactic -(** Same as [eval_tactic], but with the provided [interp_sign]. *) - -val tactic_of_value : interp_sign -> Value.t -> unit Proofview.tactic - -(** Globalization + interpretation *) - -val interp_tac_gen : value Id.Map.t -> Id.t list -> - debug_info -> raw_tactic_expr -> unit Proofview.tactic - -val interp : raw_tactic_expr -> unit Proofview.tactic - -(** Hides interpretation for pretty-print *) - -val hide_interp : bool -> raw_tactic_expr -> unit Proofview.tactic option -> unit Proofview.tactic - -(** Internals that can be useful for syntax extensions. *) - -val interp_ltac_var : (value -> 'a) -> interp_sign -> - (Environ.env * Evd.evar_map) option -> Id.t Loc.located -> 'a - -val interp_int : interp_sign -> Id.t Loc.located -> int - -val interp_int_or_var : interp_sign -> int or_var -> int - -val error_ltac_variable : Loc.t -> Id.t -> - (Environ.env * Evd.evar_map) option -> value -> string -> 'a - -(** Transforms a constr-expecting tactic into a tactic finding its arguments in - the Ltac environment according to the given names. *) -val lift_constr_tac_to_ml_tac : Id.t option list -> - (constr list -> Geninterp.interp_sign -> unit Proofview.tactic) -> Tacenv.ml_tactic - -val default_ist : unit -> Geninterp.interp_sign -(** Empty ist with debug set on the current value. *) diff --git a/ltac/tacsubst.ml b/ltac/tacsubst.ml deleted file mode 100644 index 55de58361..000000000 --- a/ltac/tacsubst.ml +++ /dev/null @@ -1,308 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* NoBindings - | ImplicitBindings l -> ImplicitBindings (List.map (subst_glob_constr subst) l) - | ExplicitBindings l -> ExplicitBindings (List.map (subst_binding subst) l) - -let subst_glob_with_bindings subst (c,bl) = - (subst_glob_constr subst c, subst_bindings subst bl) - -let subst_glob_with_bindings_arg subst (clear,c) = - (clear,subst_glob_with_bindings subst c) - -let rec subst_intro_pattern subst = function - | loc,IntroAction p -> loc, IntroAction (subst_intro_pattern_action subst p) - | loc, IntroNaming _ | loc, IntroForthcoming _ as x -> x - -and subst_intro_pattern_action subst = function - | IntroApplyOn (t,pat) -> - IntroApplyOn (subst_glob_constr subst t,subst_intro_pattern subst pat) - | IntroOrAndPattern l -> - IntroOrAndPattern (subst_intro_or_and_pattern subst l) - | IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l) - | IntroWildcard | IntroRewrite _ as x -> x - -and subst_intro_or_and_pattern subst = function - | IntroAndPattern l -> - IntroAndPattern (List.map (subst_intro_pattern subst) l) - | IntroOrPattern ll -> - IntroOrPattern (List.map (List.map (subst_intro_pattern subst)) ll) - -let subst_destruction_arg subst = function - | clear,ElimOnConstr c -> clear,ElimOnConstr (subst_glob_with_bindings subst c) - | clear,ElimOnAnonHyp n as x -> x - | clear,ElimOnIdent id as x -> x - -let subst_and_short_name f (c,n) = -(* assert (n=None); *)(* since tacdef are strictly globalized *) - (f c,None) - -let subst_or_var f = function - | ArgVar _ as x -> x - | ArgArg x -> ArgArg (f x) - -let dloc = Loc.ghost - -let subst_located f (_loc,id) = (dloc,f id) - -let subst_reference subst = - subst_or_var (subst_located (subst_kn subst)) - -(*CSC: subst_global_reference is used "only" for RefArgType, that propagates - to the syntactic non-terminals "global", used in commands such as - Print. It is also used for non-evaluable references. *) -open Pp -open Printer - -let subst_global_reference subst = - let subst_global ref = - let ref',t' = subst_global subst ref in - if not (eq_constr (Universes.constr_of_global ref') t') then - Feedback.msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ - str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++ - pr_global ref') ; - ref' - in - subst_or_var (subst_located subst_global) - -let subst_evaluable subst = - let subst_eval_ref = subst_evaluable_reference subst in - subst_or_var (subst_and_short_name subst_eval_ref) - -let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c) - -let subst_glob_constr_or_pattern subst (bvars,c,p) = - (bvars,subst_glob_constr subst c,subst_pattern subst p) - -let subst_redexp subst = - Miscops.map_red_expr_gen - (subst_glob_constr subst) - (subst_evaluable subst) - (subst_glob_constr_or_pattern subst) - -let subst_raw_may_eval subst = function - | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_glob_constr subst c) - | ConstrContext (locid,c) -> ConstrContext (locid,subst_glob_constr subst c) - | ConstrTypeOf c -> ConstrTypeOf (subst_glob_constr subst c) - | 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)) - | Term pc -> Term (subst_glob_constr_or_pattern subst pc) - -let rec subst_match_goal_hyps subst = function - | Hyp (locs,mp) :: tl -> - Hyp (locs,subst_match_pattern subst mp) - :: subst_match_goal_hyps subst tl - | Def (locs,mv,mp) :: tl -> - Def (locs,subst_match_pattern subst mv, subst_match_pattern subst mp) - :: subst_match_goal_hyps subst tl - | [] -> [] - -let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with - (* Basic tactics *) - | TacIntroPattern (ev,l) -> TacIntroPattern (ev,List.map (subst_intro_pattern subst) l) - | TacApply (a,ev,cb,cl) -> - TacApply (a,ev,List.map (subst_glob_with_bindings_arg subst) cb,cl) - | TacElim (ev,cb,cbo) -> - TacElim (ev,subst_glob_with_bindings_arg subst cb, - Option.map (subst_glob_with_bindings subst) cbo) - | TacCase (ev,cb) -> TacCase (ev,subst_glob_with_bindings_arg subst cb) - | TacMutualFix (id,n,l) -> - TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l) - | TacMutualCofix (id,l) -> - TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l) - | TacAssert (b,otac,na,c) -> - TacAssert (b,Option.map (Option.map (subst_tactic subst)) otac,na, - subst_glob_constr subst c) - | TacGeneralize cl -> - TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl) - | TacLetTac (id,c,clp,b,eqpat) -> - TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat) - - (* Derived basic tactics *) - | TacInductionDestruct (isrec,ev,(l,el)) -> - let l' = List.map (fun (c,ids,cls) -> - subst_destruction_arg subst c, ids, cls) l in - let el' = Option.map (subst_glob_with_bindings subst) el in - TacInductionDestruct (isrec,ev,(l',el')) - - (* Conversion *) - | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl) - | TacChange (op,c,cl) -> - TacChange (Option.map (subst_glob_constr_or_pattern subst) op, - subst_glob_constr subst c, cl) - - (* Equality and inversion *) - | TacRewrite (ev,l,cl,by) -> - TacRewrite (ev, - List.map (fun (b,m,c) -> - b,m,subst_glob_with_bindings_arg subst c) l, - cl,Option.map (subst_tactic subst) by) - | TacInversion (DepInversion (k,c,l),hyp) -> - TacInversion (DepInversion (k,Option.map (subst_glob_constr subst) c,l),hyp) - | TacInversion (NonDepInversion _,_) as x -> x - | TacInversion (InversionUsing (c,cl),hyp) -> - TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp) - -and subst_tactic subst (t:glob_tactic_expr) = match t with - | TacAtom (_loc,t) -> TacAtom (dloc, subst_atomic subst t) - | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun) - | TacLetIn (r,l,u) -> - let l = List.map (fun (n,b) -> (n,subst_tacarg subst b)) l in - TacLetIn (r,l,subst_tactic subst u) - | TacMatchGoal (lz,lr,lmr) -> - TacMatchGoal(lz,lr, subst_match_rule subst lmr) - | TacMatch (lz,c,lmr) -> - TacMatch (lz,subst_tactic subst c,subst_match_rule subst lmr) - | TacId _ | TacFail _ as x -> x - | TacProgress tac -> TacProgress (subst_tactic subst tac:glob_tactic_expr) - | TacShowHyps tac -> TacShowHyps (subst_tactic subst tac:glob_tactic_expr) - | TacAbstract (tac,s) -> TacAbstract (subst_tactic subst tac,s) - | TacThen (t1,t2) -> - TacThen (subst_tactic subst t1, subst_tactic subst t2) - | TacDispatch tl -> TacDispatch (List.map (subst_tactic subst) tl) - | TacExtendTac (tf,t,tl) -> - TacExtendTac (Array.map (subst_tactic subst) tf, - subst_tactic subst t, - Array.map (subst_tactic subst) tl) - | TacThens (t,tl) -> - TacThens (subst_tactic subst t, List.map (subst_tactic subst) tl) - | TacThens3parts (t1,tf,t2,tl) -> - TacThens3parts (subst_tactic subst t1,Array.map (subst_tactic subst) tf, - subst_tactic subst t2,Array.map (subst_tactic subst) tl) - | TacDo (n,tac) -> TacDo (n,subst_tactic subst tac) - | TacTimeout (n,tac) -> TacTimeout (n,subst_tactic subst tac) - | TacTime (s,tac) -> TacTime (s,subst_tactic subst tac) - | TacTry tac -> TacTry (subst_tactic subst tac) - | TacInfo tac -> TacInfo (subst_tactic subst tac) - | TacRepeat tac -> TacRepeat (subst_tactic subst tac) - | TacOr (tac1,tac2) -> - TacOr (subst_tactic subst tac1,subst_tactic subst tac2) - | TacOnce tac -> - TacOnce (subst_tactic subst tac) - | TacExactlyOnce tac -> - TacExactlyOnce (subst_tactic subst tac) - | TacIfThenCatch (tac,tact,tace) -> - TacIfThenCatch ( - subst_tactic subst tac, - subst_tactic subst tact, - subst_tactic subst tace) - | TacOrelse (tac1,tac2) -> - TacOrelse (subst_tactic subst tac1,subst_tactic subst tac2) - | TacFirst l -> TacFirst (List.map (subst_tactic subst) l) - | TacSolve l -> TacSolve (List.map (subst_tactic subst) l) - | TacComplete tac -> TacComplete (subst_tactic subst tac) - | TacArg (_,a) -> TacArg (dloc,subst_tacarg subst a) - | TacSelect (s, tac) -> TacSelect (s, subst_tactic subst tac) - - (* For extensions *) - | TacAlias (_,s,l) -> - let s = subst_kn subst s in - TacAlias (dloc,s,List.map (subst_tacarg subst) l) - | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_tacarg subst) l) - -and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) - -and subst_tacarg subst = function - | Reference r -> Reference (subst_reference subst r) - | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c) - | TacCall (_loc,f,l) -> - TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l) - | TacFreshId _ as x -> x - | TacPretype c -> TacPretype (subst_glob_constr subst c) - | TacNumgoals -> TacNumgoals - | Tacexp t -> Tacexp (subst_tactic subst t) - | TacGeneric arg -> TacGeneric (subst_genarg subst arg) - -(* Reads the rules of a Match Context or a Match *) -and subst_match_rule subst = function - | (All tc)::tl -> - (All (subst_tactic subst tc))::(subst_match_rule subst tl) - | (Pat (rl,mp,tc))::tl -> - let hyps = subst_match_goal_hyps subst rl in - let pat = subst_match_pattern subst mp in - Pat (hyps,pat,subst_tactic subst tc) - ::(subst_match_rule subst tl) - | [] -> [] - -and subst_genarg subst (GenArg (Glbwit wit, x)) = - match wit with - | ListArg wit -> - let map x = - let ans = subst_genarg subst (in_gen (glbwit wit) x) in - out_gen (glbwit wit) ans - in - in_gen (glbwit (wit_list wit)) (List.map map x) - | OptArg wit -> - let ans = match x with - | None -> in_gen (glbwit (wit_opt wit)) None - | Some x -> - let s = out_gen (glbwit wit) (subst_genarg subst (in_gen (glbwit wit) x)) in - in_gen (glbwit (wit_opt wit)) (Some s) - in - ans - | PairArg (wit1, wit2) -> - let p, q = x in - let p = out_gen (glbwit wit1) (subst_genarg subst (in_gen (glbwit wit1) p)) in - let q = out_gen (glbwit wit2) (subst_genarg subst (in_gen (glbwit wit2) q)) in - in_gen (glbwit (wit_pair wit1 wit2)) (p, q) - | ExtraArg s -> - Genintern.generic_substitute subst (in_gen (glbwit wit) x) - -(** Registering *) - -let () = - Genintern.register_subst0 wit_int_or_var (fun _ v -> v); - Genintern.register_subst0 wit_ref subst_global_reference; - Genintern.register_subst0 wit_ident (fun _ v -> v); - Genintern.register_subst0 wit_var (fun _ v -> v); - Genintern.register_subst0 wit_intro_pattern (fun _ v -> v); - Genintern.register_subst0 wit_tactic subst_tactic; - Genintern.register_subst0 wit_ltac subst_tactic; - Genintern.register_subst0 wit_constr subst_glob_constr; - Genintern.register_subst0 wit_clause_dft_concl (fun _ v -> v); - Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c); - Genintern.register_subst0 wit_open_constr (fun subst c -> subst_glob_constr subst c); - Genintern.register_subst0 wit_red_expr subst_redexp; - Genintern.register_subst0 wit_quant_hyp subst_declared_or_quantified_hypothesis; - Genintern.register_subst0 wit_bindings subst_bindings; - Genintern.register_subst0 wit_constr_with_bindings subst_glob_with_bindings; - Genintern.register_subst0 wit_destruction_arg subst_destruction_arg; - () diff --git a/ltac/tacsubst.mli b/ltac/tacsubst.mli deleted file mode 100644 index c1bf27257..000000000 --- a/ltac/tacsubst.mli +++ /dev/null @@ -1,30 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* glob_tactic_expr -> glob_tactic_expr - -(** For generic arguments, we declare and store substitutions - in a table *) - -val subst_genarg : substitution -> glob_generic_argument -> glob_generic_argument - -(** Misc *) - -val subst_glob_constr_and_expr : - substitution -> glob_constr_and_expr -> glob_constr_and_expr - -val subst_glob_with_bindings : substitution -> - glob_constr_and_expr with_bindings -> - glob_constr_and_expr with_bindings diff --git a/ltac/tactic_debug.ml b/ltac/tactic_debug.ml deleted file mode 100644 index 5cbddc7f6..000000000 --- a/ltac/tactic_debug.ml +++ /dev/null @@ -1,422 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Printer.pr_constr_pattern p) rl - -(* This module intends to be a beginning of debugger for tactic expressions. - Currently, it is quite simple and we can hope to have, in the future, a more - complete panel of commands dedicated to a proof assistant framework *) - -(* Debug information *) -type debug_info = - | DebugOn of int - | DebugOff - -(* An exception handler *) -let explain_logic_error e = - CErrors.print (fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null))) - -let explain_logic_error_no_anomaly e = - CErrors.print_no_report - (fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null))) - -let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) -let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) - -(* Prints the goal *) - -let db_pr_goal gl = - let env = Proofview.Goal.env gl in - let concl = Proofview.Goal.concl gl in - let penv = print_named_context env in - let pc = print_constr_env env concl in - str" " ++ hv 0 (penv ++ fnl () ++ - str "============================" ++ fnl () ++ - str" " ++ pc) ++ fnl () - -let db_pr_goal = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let pg = db_pr_goal gl in - Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) - end } - - -(* Prints the commands *) -let help () = - msg_tac_debug (str "Commands: = Continue" ++ fnl() ++ - str " h/? = Help" ++ fnl() ++ - str " r = Run times" ++ fnl() ++ - str " r = Run up to next idtac " ++ fnl() ++ - str " s = Skip" ++ fnl() ++ - str " x = Exit") - -(* Prints the goal and the command to be executed *) -let goal_com tac = - Proofview.tclTHEN - db_pr_goal - (Proofview.tclLIFT (msg_tac_debug (str "Going to execute:" ++ fnl () ++ prtac tac))) - -(* [run (new_ref _)] gives us a ref shared among [NonLogical.t] - expressions. It avoids parametrizing everything over a - reference. *) -let skipped = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) -let skip = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) -let breakpoint = Proofview.NonLogical.run (Proofview.NonLogical.ref None) - -let rec drop_spaces inst i = - if String.length inst > i && inst.[i] == ' ' then drop_spaces inst (i+1) - else i - -let possibly_unquote s = - if String.length s >= 2 && s.[0] == '"' && s.[String.length s - 1] == '"' then - String.sub s 1 (String.length s - 2) - else - s - -(* (Re-)initialize debugger *) -let db_initialize = - let open Proofview.NonLogical in - (skip:=0) >> (skipped:=0) >> (breakpoint:=None) - -let int_of_string s = - try Proofview.NonLogical.return (int_of_string s) - with e -> Proofview.NonLogical.raise e - -let string_get s i = - try Proofview.NonLogical.return (String.get s i) - with e -> Proofview.NonLogical.raise e - -(* Gives the number of steps or next breakpoint of a run command *) -let run_com inst = - let open Proofview.NonLogical in - string_get inst 0 >>= fun first_char -> - if first_char ='r' then - let i = drop_spaces inst 1 in - if String.length inst > i then - let s = String.sub inst i (String.length inst - i) in - if inst.[0] >= '0' && inst.[0] <= '9' then - int_of_string s >>= fun num -> - (if num<0 then invalid_arg "run_com" else return ()) >> - (skip:=num) >> (skipped:=0) - else - breakpoint:=Some (possibly_unquote s) - else - invalid_arg "run_com" - else - invalid_arg "run_com" - -(* Prints the run counter *) -let run ini = - let open Proofview.NonLogical in - if not ini then - begin - Proofview.NonLogical.print_notice (str"\b\r\b\r") >> - !skipped >>= fun skipped -> - msg_tac_debug (str "Executed expressions: " ++ int skipped ++ fnl()) - end >> - !skipped >>= fun x -> - skipped := x+1 - else - return () - -(* Prints the prompt *) -let rec prompt level = - (* spiwack: avoid overriding by the open below *) - let runtrue = run true in - begin - let open Proofview.NonLogical in - Proofview.NonLogical.print_notice (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >> - let exit = (skip:=0) >> (skipped:=0) >> raise Sys.Break in - Proofview.NonLogical.catch Proofview.NonLogical.read_line - begin function (e, info) -> match e with - | End_of_file -> exit - | e -> raise ~info e - end - >>= fun inst -> - match inst with - | "" -> return (DebugOn (level+1)) - | "s" -> return (DebugOff) - | "x" -> Proofview.NonLogical.print_char '\b' >> exit - | "h"| "?" -> - begin - help () >> - prompt level - end - | _ -> - Proofview.NonLogical.catch (run_com inst >> runtrue >> return (DebugOn (level+1))) - begin function (e, info) -> match e with - | Failure _ | Invalid_argument _ -> prompt level - | e -> raise ~info e - end - end - -(* Prints the state and waits for an instruction *) -(* spiwack: the only reason why we need to take the continuation [f] - as an argument rather than returning the new level directly seems to - be that [f] is wrapped in with "explain_logic_error". I don't think - it serves any purpose in the current design, so we could just drop - that. *) -let debug_prompt lev tac f = - (* spiwack: avoid overriding by the open below *) - let runfalse = run false in - let open Proofview.NonLogical in - let (>=) = Proofview.tclBIND in - (* What to print and to do next *) - let newlevel = - Proofview.tclLIFT !skip >= fun initial_skip -> - if Int.equal initial_skip 0 then - Proofview.tclLIFT !breakpoint >= fun breakpoint -> - if Option.is_empty breakpoint then Proofview.tclTHEN (goal_com tac) (Proofview.tclLIFT (prompt lev)) - else Proofview.tclLIFT(runfalse >> return (DebugOn (lev+1))) - else Proofview.tclLIFT begin - (!skip >>= fun s -> skip:=s-1) >> - runfalse >> - !skip >>= fun new_skip -> - (if Int.equal new_skip 0 then skipped:=0 else return ()) >> - return (DebugOn (lev+1)) - end in - newlevel >= fun newlevel -> - (* What to execute *) - Proofview.tclOR - (f newlevel) - begin fun (reraise, info) -> - Proofview.tclTHEN - (Proofview.tclLIFT begin - (skip:=0) >> (skipped:=0) >> - if Logic.catchable_exception reraise then - msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ explain_logic_error reraise) - else return () - end) - (Proofview.tclZERO ~info reraise) - end - -let is_debug db = - let open Proofview.NonLogical in - !breakpoint >>= fun breakpoint -> - match db, breakpoint with - | DebugOff, _ -> return false - | _, Some _ -> return false - | _ -> - !skip >>= fun skip -> - return (Int.equal skip 0) - -(* Prints a constr *) -let db_constr debug env c = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "Evaluated term: " ++ print_constr_env env c) - else return () - -(* Prints the pattern rule *) -let db_pattern_rule debug num r = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - begin - msg_tac_debug (str "Pattern rule " ++ int num ++ str ":" ++ fnl () ++ - str "|" ++ spc () ++ prmatchrl r) - end - else return () - -(* Prints the hypothesis pattern identifier if it exists *) -let hyp_bound = function - | Anonymous -> str " (unbound)" - | Name id -> str " (bound to " ++ pr_id id ++ str ")" - -(* Prints a matched hypothesis *) -let db_matched_hyp debug env (id,_,c) ido = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "Hypothesis " ++ pr_id id ++ hyp_bound ido ++ - str " has been matched: " ++ print_constr_env env c) - else return () - -(* Prints the matched conclusion *) -let db_matched_concl debug env c = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "Conclusion has been matched: " ++ print_constr_env env c) - else return () - -(* Prints a success message when the goal has been matched *) -let db_mc_pattern_success debug = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "The goal has been successfully matched!" ++ fnl() ++ - str "Let us execute the right-hand side part..." ++ fnl()) - else return () - -(* Prints a failure message for an hypothesis pattern *) -let db_hyp_pattern_failure debug env sigma (na,hyp) = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "The pattern hypothesis" ++ hyp_bound na ++ - str " cannot match: " ++ - prmatchpatt env sigma hyp) - else return () - -(* Prints a matching failure message for a rule *) -let db_matching_failure debug = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "This rule has failed due to matching errors!" ++ fnl() ++ - str "Let us try the next one...") - else return () - -(* Prints an evaluation failure message for a rule *) -let db_eval_failure debug s = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - let s = str "message \"" ++ s ++ str "\"" in - msg_tac_debug - (str "This rule has failed due to \"Fail\" tactic (" ++ - s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...") - else return () - -(* Prints a logic failure message for a rule *) -let db_logic_failure debug err = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - begin - msg_tac_debug (explain_logic_error err) >> - msg_tac_debug (str "This rule has failed due to a logic error!" ++ fnl() ++ - str "Let us try the next one...") - end - else return () - -let is_breakpoint brkname s = match brkname, s with - | Some s, MsgString s'::_ -> String.equal s s' - | _ -> false - -let db_breakpoint debug s = - let open Proofview.NonLogical in - !breakpoint >>= fun opt_breakpoint -> - match debug with - | DebugOn lev when not (CList.is_empty s) && is_breakpoint opt_breakpoint s -> - breakpoint:=None - | _ -> - return () - -(** Extrating traces *) - -let is_defined_ltac trace = - let rec aux = function - | (_, Tacexpr.LtacNameCall f) :: _ -> not (Tacenv.is_ltac_for_ml_tactic f) - | (_, Tacexpr.LtacNotationCall f) :: _ -> true - | (_, Tacexpr.LtacAtomCall _) :: _ -> false - | _ :: tail -> aux tail - | [] -> false in - aux (List.rev trace) - -let explain_ltac_call_trace last trace loc = - let calls = last :: List.rev_map snd trace in - let pr_call ck = match ck with - | Tacexpr.LtacNotationCall kn -> quote (Pptactic.pr_alias_key kn) - | Tacexpr.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) - | Tacexpr.LtacMLCall t -> - quote (Pptactic.pr_glob_tactic (Global.env()) t) - | Tacexpr.LtacVarCall (id,t) -> - quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ - Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" - | Tacexpr.LtacAtomCall te -> - quote (Pptactic.pr_glob_tactic (Global.env()) - (Tacexpr.TacAtom (Loc.ghost,te))) - | Tacexpr.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) -> - quote (Printer.pr_glob_constr_env (Global.env()) c) ++ - (if not (Id.Map.is_empty vars) then - strbrk " (with " ++ - prlist_with_sep pr_comma - (fun (id,c) -> - pr_id id ++ str ":=" ++ Printer.pr_lconstr_under_binders c) - (List.rev (Id.Map.bindings vars)) ++ str ")" - else mt()) - in - match calls with - | [] -> mt () - | [a] -> hov 0 (str "Ltac call to " ++ pr_call a ++ str " failed.") - | _ -> - let kind_of_last_call = match List.last calls with - | Tacexpr.LtacConstrInterp _ -> ", last term evaluation failed." - | _ -> ", last call failed." - in - hov 0 (str "In nested Ltac calls to " ++ - pr_enum pr_call calls ++ strbrk kind_of_last_call) - -let skip_extensions trace = - let rec aux = function - | (_,Tacexpr.LtacNameCall f as tac) :: _ - when Tacenv.is_ltac_for_ml_tactic f -> [tac] - | (_,Tacexpr.LtacNotationCall _ as tac) :: (_,Tacexpr.LtacMLCall _) :: _ -> - (* Case of an ML defined tactic with entry of the form <<"foo" args>> *) - (* see tacextend.mlp *) - [tac] - | (_,Tacexpr.LtacMLCall _ as tac) :: _ -> [tac] - | t :: tail -> t :: aux tail - | [] -> [] in - List.rev (aux (List.rev trace)) - -let finer_loc loc1 loc2 = Loc.merge loc1 loc2 = loc2 - -let extract_ltac_trace trace eloc = - let trace = skip_extensions trace in - let (loc,c),tail = List.sep_last trace in - if is_defined_ltac trace then - (* We entered a user-defined tactic, - we display the trace with location of the call *) - let msg = hov 0 (explain_ltac_call_trace c tail eloc ++ fnl()) in - Some msg, if finer_loc eloc loc then eloc else loc - else - (* We entered a primitive tactic, we don't display trace but - report on the finest location *) - let best_loc = - (* trace is with innermost call coming first *) - let rec aux best_loc = function - | (loc,_)::tail -> - if Loc.is_ghost best_loc || - not (Loc.is_ghost loc) && finer_loc loc best_loc - then - aux loc tail - else - aux best_loc tail - | [] -> best_loc in - aux eloc trace in - None, best_loc - -let get_ltac_trace (_, info) = - let ltac_trace = Exninfo.get info ltac_trace_info in - let loc = Option.default Loc.ghost (Loc.get_loc info) in - match ltac_trace with - | None -> None - | Some trace -> Some (extract_ltac_trace trace loc) - -let () = ExplainErr.register_additional_error_info get_ltac_trace diff --git a/ltac/tactic_debug.mli b/ltac/tactic_debug.mli deleted file mode 100644 index 520fb41ef..000000000 --- a/ltac/tactic_debug.mli +++ /dev/null @@ -1,80 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* glob_tactic_expr -> (debug_info -> 'a Proofview.tactic) -> 'a Proofview.tactic - -(** Initializes debugger *) -val db_initialize : unit Proofview.NonLogical.t - -(** Prints a constr *) -val db_constr : debug_info -> env -> constr -> unit Proofview.NonLogical.t - -(** Prints the pattern rule *) -val db_pattern_rule : - debug_info -> int -> (Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t - -(** Prints a matched hypothesis *) -val db_matched_hyp : - debug_info -> env -> Id.t * constr option * constr -> Name.t -> unit Proofview.NonLogical.t - -(** Prints the matched conclusion *) -val db_matched_concl : debug_info -> env -> constr -> unit Proofview.NonLogical.t - -(** Prints a success message when the goal has been matched *) -val db_mc_pattern_success : debug_info -> unit Proofview.NonLogical.t - -(** Prints a failure message for an hypothesis pattern *) -val db_hyp_pattern_failure : - debug_info -> env -> evar_map -> Name.t * constr_pattern match_pattern -> unit Proofview.NonLogical.t - -(** Prints a matching failure message for a rule *) -val db_matching_failure : debug_info -> unit Proofview.NonLogical.t - -(** Prints an evaluation failure message for a rule *) -val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit Proofview.NonLogical.t - -(** An exception handler *) -val explain_logic_error: exn -> Pp.std_ppcmds - -(** For use in the Ltac debugger: some exception that are usually - consider anomalies are acceptable because they are caught later in - the process that is being debugged. One should not require - from users that they report these anomalies. *) -val explain_logic_error_no_anomaly : exn -> Pp.std_ppcmds - -(** Prints a logic failure message for a rule *) -val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t - -(** Prints a logic failure message for a rule *) -val db_breakpoint : debug_info -> - Id.t Loc.located message_token list -> unit Proofview.NonLogical.t - -val extract_ltac_trace : - Tacexpr.ltac_trace -> Loc.t -> Pp.std_ppcmds option * Loc.t diff --git a/ltac/tactic_matching.ml b/ltac/tactic_matching.ml deleted file mode 100644 index ef45ee47e..000000000 --- a/ltac/tactic_matching.ml +++ /dev/null @@ -1,377 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - Constr_matching.bound_ident_map * Pattern.extended_patvar_map = - fun (l, lc) -> (l, Id.Map.map (fun c -> [], c) lc) - - -(** Adds a binding to a {!Id.Map.t} if the identifier is [Some id] *) -let id_map_try_add id x m = - match id with - | Some id -> Id.Map.add id x m - | None -> m - -(** Adds a binding to a {!Id.Map.t} if the name is [Name id] *) -let id_map_try_add_name id x m = - match id with - | Name id -> Id.Map.add id x m - | Anonymous -> m - -(** Takes the union of two {!Id.Map.t}. If there is conflict, - the binding of the right-hand argument shadows that of the left-hand - argument. *) -let id_map_right_biased_union m1 m2 = - if Id.Map.is_empty m1 then m2 (** Don't reconstruct the whole map *) - else Id.Map.fold Id.Map.add m2 m1 - -(** Tests whether the substitution [s] is empty. *) -let is_empty_subst (ln,lm) = - Id.Map.(is_empty ln && is_empty lm) - -(** {6 Non-linear patterns} *) - - -(** The patterns of Ltac are not necessarily linear. Non-linear - pattern are partially handled by the {!Matching} module, however - goal patterns are not primitive to {!Matching}, hence we must deal - with non-linearity between hypotheses and conclusion. Subterms are - considered equal up to the equality implemented in - [equal_instances]. *) -(* spiwack: it doesn't seem to be quite the same rule for non-linear - term patterns and non-linearity between hypotheses and/or - conclusion. Indeed, in [Matching], matching is made modulo - syntactic equality, and here we merge modulo conversion. It may be - a good idea to have an entry point of [Matching] with a partial - substitution as argument instead of merging substitution here. That - would ensure consistency. *) -let equal_instances env sigma (ctx',c') (ctx,c) = - (* How to compare instances? Do we want the terms to be convertible? - unifiable? Do we want the universe levels to be relevant? - (historically, conv_x is used) *) - CList.equal Id.equal ctx ctx' && Reductionops.is_conv env sigma c' c - - -(** Merges two substitutions. Raises [Not_coherent_metas] when - encountering two instances of the same metavariable which are not - equal according to {!equal_instances}. *) -exception Not_coherent_metas -let verify_metas_coherence env sigma (ln1,lcm) (ln,lm) = - let merge id oc1 oc2 = match oc1, oc2 with - | None, None -> None - | None, Some c | Some c, None -> Some c - | Some c1, Some c2 -> - if equal_instances env sigma c1 c2 then Some c1 - else raise Not_coherent_metas - in - let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 in - (** ppedrot: Is that even correct? *) - let merged = ln +++ ln1 in - (merged, Id.Map.merge merge lcm lm) - -let matching_error = - CErrors.UserError (Some "tactic matching" , Pp.str "No matching clauses for match.") - -let imatching_error = (matching_error, Exninfo.null) - -(** A functor is introduced to share the environment and the - evar_map. They do not change and it would be a pity to introduce - closures everywhere just for the occasional calls to - {!equal_instances}. *) -module type StaticEnvironment = sig - val env : Environ.env - val sigma : Evd.evar_map -end -module PatternMatching (E:StaticEnvironment) = struct - - - (** {6 The pattern-matching monad } *) - - - (** To focus on the algorithmic portion of pattern-matching, the - bookkeeping is relegated to a monad: the composition of the - bactracking monad of {!IStream.t} with a "writer" effect. *) - (* spiwack: as we don't benefit from the various stream optimisations - of Haskell, it may be costly to give the monad in direct style such as - here. We may want to use some continuation passing style. *) - type 'a tac = 'a Proofview.tactic - type 'a m = { stream : 'r. ('a -> unit t -> 'r tac) -> unit t -> 'r tac } - - (** The empty substitution. *) - let empty_subst = Id.Map.empty , Id.Map.empty - - (** Composes two substitutions using {!verify_metas_coherence}. It - must be a monoid with neutral element {!empty_subst}. Raises - [Not_coherent_metas] when composition cannot be achieved. *) - let subst_prod s1 s2 = - if is_empty_subst s1 then s2 - else if is_empty_subst s2 then s1 - else verify_metas_coherence E.env E.sigma s1 s2 - - (** The empty context substitution. *) - let empty_context_subst = Id.Map.empty - - (** Compose two context substitutions, in case of conflict the - right hand substitution shadows the left hand one. *) - let context_subst_prod = id_map_right_biased_union - - (** The empty term substitution. *) - let empty_term_subst = Id.Map.empty - - (** Compose two terms substitutions, in case of conflict the - right hand substitution shadows the left hand one. *) - let term_subst_prod = id_map_right_biased_union - - (** Merge two writers (and ignore the first value component). *) - let merge m1 m2 = - try Some { - subst = subst_prod m1.subst m2.subst; - context = context_subst_prod m1.context m2.context; - terms = term_subst_prod m1.terms m2.terms; - lhs = m2.lhs; - } - with Not_coherent_metas -> None - - (** Monadic [return]: returns a single success with empty substitutions. *) - let return (type a) (lhs:a) : a m = - { stream = fun k ctx -> k lhs ctx } - - (** Monadic bind: each success of [x] is replaced by the successes - of [f x]. The substitutions of [x] and [f x] are composed, - dropping the apparent successes when the substitutions are not - coherent. *) - let (>>=) (type a) (type b) (m:a m) (f:a -> b m) : b m = - { stream = fun k ctx -> m.stream (fun x ctx -> (f x).stream k ctx) ctx } - - (** A variant of [(>>=)] when the first argument returns [unit]. *) - let (<*>) (type a) (m:unit m) (y:a m) : a m = - { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx } - - (** Failure of the pattern-matching monad: no success. *) - let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error } - - let run (m : 'a m) = - let ctx = { - subst = empty_subst ; - context = empty_context_subst ; - terms = empty_term_subst ; - lhs = (); - } in - let eval lhs ctx = Proofview.tclUNIT { ctx with lhs } in - m.stream eval ctx - - (** Chooses in a list, in the same order as the list *) - let rec pick (l:'a list) (e, info) : 'a m = match l with - | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } - | x :: l -> - { stream = fun k ctx -> Proofview.tclOR (k x ctx) (fun e -> (pick l e).stream k ctx) } - - let pick l = pick l imatching_error - - (** Declares a subsitution, a context substitution and a term substitution. *) - let put subst context terms : unit m = - let s = { subst ; context ; terms ; lhs = () } in - { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s } - - (** Declares a substitution. *) - let put_subst subst : unit m = put subst empty_context_subst empty_term_subst - - (** Declares a term substitution. *) - let put_terms terms : unit m = put empty_subst empty_context_subst terms - - - - (** {6 Pattern-matching} *) - - - (** [wildcard_match_term lhs] matches a term against a wildcard - pattern ([_ => lhs]). It has a single success with an empty - substitution. *) - let wildcard_match_term = return - - (** [pattern_match_term refresh pat term lhs] returns the possible - matchings of [term] with the pattern [pat => lhs]. If refresh is - true, refreshes the universes of [term]. *) - let pattern_match_term refresh pat term lhs = -(* let term = if refresh then Termops.refresh_universes_strict term else term in *) - match pat with - | Term p -> - begin - try - put_subst (Constr_matching.extended_matches E.env E.sigma p term) <*> - return lhs - with Constr_matching.PatternMatchingFailure -> fail - end - | Subterm (with_app_context,id_ctxt,p) -> - - let rec map s (e, info) = - { stream = fun k ctx -> match IStream.peek s with - | IStream.Nil -> Proofview.tclZERO ~info e - | IStream.Cons ({ Constr_matching.m_sub ; m_ctx }, s) -> - let subst = adjust m_sub in - let context = id_map_try_add id_ctxt m_ctx Id.Map.empty in - let terms = empty_term_subst in - let nctx = { subst ; context ; terms ; lhs = () } in - match merge ctx nctx with - | None -> (map s (e, info)).stream k ctx - | 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 - - - (** [rule_match_term term rule] matches the term [term] with the - matching rule [rule]. *) - let rule_match_term term = function - | All lhs -> wildcard_match_term lhs - | Pat ([],pat,lhs) -> pattern_match_term false pat term lhs - | Pat _ -> - (** Rules with hypotheses, only work in match goal. *) - fail - - (** [match_term term rules] matches the term [term] with the set of - matching rules [rules].*) - let rec match_term (e, info) term rules = match rules with - | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } - | r :: rules -> - { stream = fun k ctx -> - let head = rule_match_term term r in - let tail e = match_term e term rules in - Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx) - } - - - (** [hyp_match_type hypname pat hyps] matches a single - hypothesis pattern [hypname:pat] against the hypotheses in - [hyps]. Tries the hypotheses in order. For each success returns - the name of the matched hypothesis. *) - let hyp_match_type hypname pat hyps = - pick hyps >>= fun decl -> - let id = NamedDecl.get_id decl in - let refresh = is_local_def decl in - pattern_match_term refresh pat (NamedDecl.get_type decl) () <*> - put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*> - return id - - (** [hyp_match_type hypname bodypat typepat hyps] matches a single - hypothesis pattern [hypname := bodypat : typepat] against the - hypotheses in [hyps].Tries the hypotheses in order. For each - success returns the name of the matched hypothesis. *) - let hyp_match_body_and_type hypname bodypat typepat hyps = - pick hyps >>= function - | LocalDef (id,body,hyp) -> - pattern_match_term false bodypat body () <*> - pattern_match_term true typepat hyp () <*> - put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*> - return id - | LocalAssum (id,hyp) -> fail - - (** [hyp_match pat hyps] dispatches to - {!hyp_match_type} or {!hyp_match_body_and_type} depending on whether - [pat] is [Hyp _] or [Def _]. *) - let hyp_match pat hyps = - match pat with - | Hyp ((_,hypname),typepat) -> - hyp_match_type hypname typepat hyps - | Def ((_,hypname),bodypat,typepat) -> - hyp_match_body_and_type hypname bodypat typepat hyps - - (** [hyp_pattern_list_match pats hyps lhs], matches the list of - patterns [pats] against the hypotheses in [hyps], and eventually - returns [lhs]. *) - let rec hyp_pattern_list_match pats hyps lhs = - match pats with - | pat::pats -> - hyp_match pat hyps >>= fun matched_hyp -> - (* spiwack: alternatively it is possible to return the list - with the matched hypothesis removed directly in - [hyp_match]. *) - let select_matched_hyp decl = Id.equal (NamedDecl.get_id decl) matched_hyp in - let hyps = CList.remove_first select_matched_hyp hyps in - hyp_pattern_list_match pats hyps lhs - | [] -> return lhs - - (** [rule_match_goal hyps concl rule] matches the rule [rule] - against the goal [hyps|-concl]. *) - let rule_match_goal hyps concl = function - | All lhs -> wildcard_match_term lhs - | Pat (hyppats,conclpat,lhs) -> - (* the rules are applied from the topmost one (in the concrete - syntax) to the bottommost. *) - let hyppats = List.rev hyppats in - pattern_match_term false conclpat concl () <*> - hyp_pattern_list_match hyppats hyps lhs - - (** [match_goal hyps concl rules] matches the goal [hyps|-concl] - with the set of matching rules [rules]. *) - let rec match_goal (e, info) hyps concl rules = match rules with - | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } - | r :: rules -> - { stream = fun k ctx -> - let head = rule_match_goal hyps concl r in - let tail e = match_goal e hyps concl rules in - Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx) - } - -end - -(** [match_term env sigma term rules] matches the term [term] with the - set of matching rules [rules]. The environment [env] and the - evar_map [sigma] are not currently used, but avoid code - duplication. *) -let match_term env sigma term rules = - let module E = struct - let env = env - let sigma = sigma - end in - let module M = PatternMatching(E) in - M.run (M.match_term imatching_error term rules) - - -(** [match_goal env sigma hyps concl rules] matches the goal - [hyps|-concl] with the set of matching rules [rules]. The - environment [env] and the evar_map [sigma] are used to check - convertibility for pattern variables shared between hypothesis - patterns or the conclusion pattern. *) -let match_goal env sigma hyps concl rules = - let module E = struct - let env = env - let sigma = sigma - end in - let module M = PatternMatching(E) in - M.run (M.match_goal imatching_error hyps concl rules) diff --git a/ltac/tactic_matching.mli b/ltac/tactic_matching.mli deleted file mode 100644 index 090207bcc..000000000 --- a/ltac/tactic_matching.mli +++ /dev/null @@ -1,49 +0,0 @@ - (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - Evd.evar_map -> - Term.constr -> - (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> - Tacexpr.glob_tactic_expr t Proofview.tactic - -(** [match_goal env sigma hyps concl rules] matches the goal - [hyps|-concl] with the set of matching rules [rules]. The - environment [env] and the evar_map [sigma] are used to check - convertibility for pattern variables shared between hypothesis - patterns or the conclusion pattern. *) -val match_goal: - Environ.env -> - Evd.evar_map -> - Context.Named.t -> - Term.constr -> - (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> - Tacexpr.glob_tactic_expr t Proofview.tactic diff --git a/ltac/tactic_option.ml b/ltac/tactic_option.ml deleted file mode 100644 index a5ba3b837..000000000 --- a/ltac/tactic_option.ml +++ /dev/null @@ -1,51 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* obj = - declare_object - { (default_object name) with - cache_function = cache; - load_function = (fun _ -> load); - open_function = (fun _ -> load); - classify_function = (fun (local, tac) -> - if local then Dispose else Substitute (local, tac)); - subst_function = subst} - in - let put local tac = - set_default_tactic local tac; - Lib.add_anonymous_leaf (input (local, tac)) - in - let get () = !locality, Tacinterp.eval_tactic !default_tactic in - let print () = - Pptactic.pr_glob_tactic (Global.env ()) !default_tactic_expr ++ - (if !locality then str" (locally defined)" else str" (globally defined)") - in - put, get, print diff --git a/ltac/tactic_option.mli b/ltac/tactic_option.mli deleted file mode 100644 index ed759a76d..000000000 --- a/ltac/tactic_option.mli +++ /dev/null @@ -1,15 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* string -> - (* put *) (locality_flag -> glob_tactic_expr -> unit) * - (* get *) (unit -> locality_flag * unit Proofview.tactic) * - (* print *) (unit -> Pp.std_ppcmds) diff --git a/ltac/tauto.ml b/ltac/tauto.ml deleted file mode 100644 index 756958c2f..000000000 --- a/ltac/tauto.ml +++ /dev/null @@ -1,279 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* c - | None -> failwith "tauto: anomaly" - -(** Parametrization of tauto *) - -type tauto_flags = { - -(* Whether conjunction and disjunction are restricted to binary connectives *) - binary_mode : bool; - -(* Whether compatibility for buggy detection of binary connective is on *) - binary_mode_bugged_detection : bool; - -(* Whether conjunction and disjunction are restricted to the connectives *) -(* having the structure of "and" and "or" (up to the choice of sorts) in *) -(* contravariant position in an hypothesis *) - strict_in_contravariant_hyp : bool; - -(* Whether conjunction and disjunction are restricted to the connectives *) -(* having the structure of "and" and "or" (up to the choice of sorts) in *) -(* an hypothesis and in the conclusion *) - strict_in_hyp_and_ccl : bool; - -(* Whether unit type includes equality types *) - strict_unit : bool; -} - -let tag_tauto_flags : tauto_flags Val.typ = Val.create "tauto_flags" - -let assoc_flags ist : tauto_flags = - let Val.Dyn (tag, v) = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in - match Val.eq tag tag_tauto_flags with - | None -> assert false - | Some Refl -> v - -(* Whether inner not are unfolded *) -let negation_unfolding = ref true - -(* Whether inner iff are unfolded *) -let iff_unfolding = ref false - -let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2 - -open Goptions -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "unfolding of not in intuition"; - optkey = ["Intuition";"Negation";"Unfolding"]; - optread = (fun () -> !negation_unfolding); - optwrite = (:=) negation_unfolding } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "unfolding of iff in intuition"; - optkey = ["Intuition";"Iff";"Unfolding"]; - optread = (fun () -> !iff_unfolding); - optwrite = (:=) iff_unfolding } - -(** Base tactics *) - -let loc = Loc.ghost -let idtac = Proofview.tclUNIT () -let fail = Proofview.tclINDEPENDENT (tclFAIL 0 (Pp.mt ())) - -let intro = Tactics.intro - -let assert_ ?by c = - let tac = match by with - | None -> None - | Some tac -> Some (Some tac) - in - Proofview.tclINDEPENDENT (Tactics.forward true tac None c) - -let apply c = Tactics.apply c - -let clear id = Tactics.clear [id] - -let assumption = Tactics.assumption - -let split = Tactics.split_with_bindings false [Misctypes.NoBindings] - -(** Test *) - -let is_empty _ ist = - if is_empty_type (assoc_var "X1" ist) then idtac else fail - -(* Strictly speaking, this exceeds the propositional fragment as it - matches also equality types (and solves them if a reflexivity) *) -let is_unit_or_eq _ ist = - let flags = assoc_flags ist in - let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in - if test (assoc_var "X1" ist) then idtac else fail - -let bugged_is_binary t = - isApp t && - let (hdapp,args) = decompose_app t in - match (kind_of_term hdapp) with - | Ind (ind,u) -> - let (mib,mip) = Global.lookup_inductive ind in - Int.equal mib.Declarations.mind_nparams 2 - | _ -> false - -(** Dealing with conjunction *) - -let is_conj _ ist = - let flags = assoc_flags ist in - let ind = assoc_var "X1" ist in - if (not flags.binary_mode_bugged_detection || bugged_is_binary ind) && - is_conjunction - ~strict:flags.strict_in_hyp_and_ccl - ~onlybinary:flags.binary_mode ind - then idtac - else fail - -let flatten_contravariant_conj _ ist = - let flags = assoc_flags ist in - let typ = assoc_var "X1" ist in - let c = assoc_var "X2" ist in - let hyp = assoc_var "id" ist in - match match_with_conjunction - ~strict:flags.strict_in_contravariant_hyp - ~onlybinary:flags.binary_mode typ - with - | Some (_,args) -> - let newtyp = List.fold_right mkArrow args c in - let intros = tclMAP (fun _ -> intro) args in - let by = tclTHENLIST [intros; apply hyp; split; assumption] in - tclTHENLIST [assert_ ~by newtyp; clear (destVar hyp)] - | _ -> fail - -(** Dealing with disjunction *) - -let is_disj _ ist = - let flags = assoc_flags ist in - let t = assoc_var "X1" ist in - if (not flags.binary_mode_bugged_detection || bugged_is_binary t) && - is_disjunction - ~strict:flags.strict_in_hyp_and_ccl - ~onlybinary:flags.binary_mode t - then idtac - else fail - -let flatten_contravariant_disj _ ist = - let flags = assoc_flags ist in - let typ = assoc_var "X1" ist in - let c = assoc_var "X2" ist in - let hyp = assoc_var "id" ist in - match match_with_disjunction - ~strict:flags.strict_in_contravariant_hyp - ~onlybinary:flags.binary_mode - typ with - | Some (_,args) -> - let map i arg = - let typ = mkArrow arg c in - let ci = Tactics.constructor_tac false None (succ i) Misctypes.NoBindings in - let by = tclTHENLIST [intro; apply hyp; ci; assumption] in - assert_ ~by typ - in - let tacs = List.mapi map args in - let tac0 = clear (destVar hyp) in - tclTHEN (tclTHENLIST tacs) tac0 - | _ -> fail - -let make_unfold name = - let dir = DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]) in - let const = Constant.make2 (MPfile dir) (Label.make name) in - (Locus.AllOccurrences, ArgArg (EvalConstRef const, None)) - -let u_iff = make_unfold "iff" -let u_not = make_unfold "not" - -let reduction_not_iff _ ist = - let make_reduce c = TacAtom (loc, TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in - let tac = match !negation_unfolding, unfold_iff () with - | true, true -> make_reduce [u_not; u_iff] - | true, false -> make_reduce [u_not] - | false, true -> make_reduce [u_iff] - | false, false -> TacId [] - in - eval_tactic_ist ist tac - -let coq_nnpp_path = - let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in - Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP") - -let apply_nnpp _ ist = - Proofview.tclBIND - (Proofview.tclUNIT ()) - begin fun () -> try - let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in - apply nnpp - with Not_found -> tclFAIL 0 (Pp.mt ()) - end - -(* This is the uniform mode dealing with ->, not, iff and types isomorphic to - /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types. - For the moment not and iff are still always unfolded. *) -let tauto_uniform_unit_flags = { - binary_mode = true; - binary_mode_bugged_detection = false; - strict_in_contravariant_hyp = true; - strict_in_hyp_and_ccl = true; - strict_unit = false -} - -(* This is the compatibility mode (not used) *) -let tauto_legacy_flags = { - binary_mode = true; - binary_mode_bugged_detection = true; - strict_in_contravariant_hyp = true; - strict_in_hyp_and_ccl = false; - strict_unit = false -} - -(* This is the improved mode *) -let tauto_power_flags = { - binary_mode = false; (* support n-ary connectives *) - binary_mode_bugged_detection = false; - strict_in_contravariant_hyp = false; (* supports non-regular connectives *) - strict_in_hyp_and_ccl = false; - strict_unit = false -} - -let with_flags flags _ ist = - let f = (loc, Id.of_string "f") in - let x = (loc, Id.of_string "x") in - let arg = Val.Dyn (tag_tauto_flags, flags) in - let ist = { ist with lfun = Id.Map.add (snd x) arg ist.lfun } in - eval_tactic_ist ist (TacArg (loc, TacCall (loc, ArgVar f, [Reference (ArgVar x)]))) - -let register_tauto_tactic tac name0 args = - let ids = List.map (fun id -> Id.of_string id) args in - let ids = List.map (fun id -> Some id) ids in - let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in - let entry = { mltac_name = name; mltac_index = 0 } in - let () = Tacenv.register_ml_tactic name [| tac |] in - let tac = TacFun (ids, TacML (loc, entry, [])) in - let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in - Mltop.declare_cache_obj obj tauto_plugin - -let () = register_tauto_tactic is_empty "is_empty" ["tauto_flags"; "X1"] -let () = register_tauto_tactic is_unit_or_eq "is_unit_or_eq" ["tauto_flags"; "X1"] -let () = register_tauto_tactic is_disj "is_disj" ["tauto_flags"; "X1"] -let () = register_tauto_tactic is_conj "is_conj" ["tauto_flags"; "X1"] -let () = register_tauto_tactic flatten_contravariant_disj "flatten_contravariant_disj" ["tauto_flags"; "X1"; "X2"; "id"] -let () = register_tauto_tactic flatten_contravariant_conj "flatten_contravariant_conj" ["tauto_flags"; "X1"; "X2"; "id"] -let () = register_tauto_tactic apply_nnpp "apply_nnpp" [] -let () = register_tauto_tactic reduction_not_iff "reduction_not_iff" [] -let () = register_tauto_tactic (with_flags tauto_uniform_unit_flags) "with_uniform_flags" ["f"] -let () = register_tauto_tactic (with_flags tauto_power_flags) "with_power_flags" ["f"] diff --git a/ltac/tauto.mli b/ltac/tauto.mli deleted file mode 100644 index e69de29bb..000000000 diff --git a/plugins/ltac/Ltac.v b/plugins/ltac/Ltac.v new file mode 100644 index 000000000..e69de29bb diff --git a/plugins/ltac/coretactics.ml4 b/plugins/ltac/coretactics.ml4 new file mode 100644 index 000000000..28ff6df83 --- /dev/null +++ b/plugins/ltac/coretactics.ml4 @@ -0,0 +1,329 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ Tactics.intros_reflexivity ] +END + +TACTIC EXTEND exact + [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ] +END + +TACTIC EXTEND assumption + [ "assumption" ] -> [ Tactics.assumption ] +END + +TACTIC EXTEND etransitivity + [ "etransitivity" ] -> [ Tactics.intros_transitivity None ] +END + +TACTIC EXTEND cut + [ "cut" constr(c) ] -> [ Tactics.cut c ] +END + +TACTIC EXTEND exact_no_check + [ "exact_no_check" constr(c) ] -> [ Tactics.exact_no_check c ] +END + +TACTIC EXTEND vm_cast_no_check + [ "vm_cast_no_check" constr(c) ] -> [ Tactics.vm_cast_no_check c ] +END + +TACTIC EXTEND native_cast_no_check + [ "native_cast_no_check" constr(c) ] -> [ Tactics.native_cast_no_check c ] +END + +TACTIC EXTEND casetype + [ "casetype" constr(c) ] -> [ Tactics.case_type c ] +END + +TACTIC EXTEND elimtype + [ "elimtype" constr(c) ] -> [ Tactics.elim_type c ] +END + +TACTIC EXTEND lapply + [ "lapply" constr(c) ] -> [ Tactics.cut_and_apply c ] +END + +TACTIC EXTEND transitivity + [ "transitivity" constr(c) ] -> [ Tactics.intros_transitivity (Some c) ] +END + +(** Left *) + +TACTIC EXTEND left + [ "left" ] -> [ Tactics.left_with_bindings false NoBindings ] +END + +TACTIC EXTEND eleft + [ "eleft" ] -> [ Tactics.left_with_bindings true NoBindings ] +END + +TACTIC EXTEND left_with + [ "left" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.left_with_bindings false bl) + ] +END + +TACTIC EXTEND eleft_with + [ "eleft" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.left_with_bindings true bl) + ] +END + +(** Right *) + +TACTIC EXTEND right + [ "right" ] -> [ Tactics.right_with_bindings false NoBindings ] +END + +TACTIC EXTEND eright + [ "eright" ] -> [ Tactics.right_with_bindings true NoBindings ] +END + +TACTIC EXTEND right_with + [ "right" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.right_with_bindings false bl) + ] +END + +TACTIC EXTEND eright_with + [ "eright" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.right_with_bindings true bl) + ] +END + +(** Constructor *) + +TACTIC EXTEND constructor + [ "constructor" ] -> [ Tactics.any_constructor false None ] +| [ "constructor" int_or_var(i) ] -> [ + Tactics.constructor_tac false None i NoBindings + ] +| [ "constructor" int_or_var(i) "with" bindings(bl) ] -> [ + let tac bl = Tactics.constructor_tac false None i bl in + Tacticals.New.tclDELAYEDWITHHOLES false bl tac + ] +END + +TACTIC EXTEND econstructor + [ "econstructor" ] -> [ Tactics.any_constructor true None ] +| [ "econstructor" int_or_var(i) ] -> [ + Tactics.constructor_tac true None i NoBindings + ] +| [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> [ + let tac bl = Tactics.constructor_tac true None i bl in + Tacticals.New.tclDELAYEDWITHHOLES true bl tac + ] +END + +(** Specialize *) + +TACTIC EXTEND specialize + [ "specialize" constr_with_bindings(c) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> Tactics.specialize c None) + ] +| [ "specialize" constr_with_bindings(c) "as" intropattern(ipat) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> Tactics.specialize c (Some ipat)) + ] +END + +TACTIC EXTEND symmetry + [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ] +END + +TACTIC EXTEND symmetry_in +| [ "symmetry" "in" in_clause(cl) ] -> [ Tactics.intros_symmetry cl ] +END + +(** Split *) + +let rec delayed_list = function +| [] -> { Tacexpr.delayed = fun _ sigma -> Sigma.here [] sigma } +| x :: l -> + { Tacexpr.delayed = fun env sigma -> + let Sigma (x, sigma, p) = x.Tacexpr.delayed env sigma in + let Sigma (l, sigma, q) = (delayed_list l).Tacexpr.delayed env sigma in + Sigma (x :: l, sigma, p +> q) } + +TACTIC EXTEND split + [ "split" ] -> [ Tactics.split_with_bindings false [NoBindings] ] +END + +TACTIC EXTEND esplit + [ "esplit" ] -> [ Tactics.split_with_bindings true [NoBindings] ] +END + +TACTIC EXTEND split_with + [ "split" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.split_with_bindings false [bl]) + ] +END + +TACTIC EXTEND esplit_with + [ "esplit" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.split_with_bindings true [bl]) + ] +END + +TACTIC EXTEND exists + [ "exists" ] -> [ Tactics.split_with_bindings false [NoBindings] ] +| [ "exists" ne_bindings_list_sep(bll, ",") ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false (delayed_list bll) (fun bll -> Tactics.split_with_bindings false bll) + ] +END + +TACTIC EXTEND eexists + [ "eexists" ] -> [ Tactics.split_with_bindings true [NoBindings] ] +| [ "eexists" ne_bindings_list_sep(bll, ",") ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES true (delayed_list bll) (fun bll -> Tactics.split_with_bindings true bll) + ] +END + +(** Intro *) + +TACTIC EXTEND intros_until + [ "intros" "until" quantified_hypothesis(h) ] -> [ Tactics.intros_until h ] +END + +TACTIC EXTEND intro +| [ "intro" ] -> [ Tactics.intro_move None MoveLast ] +| [ "intro" ident(id) ] -> [ Tactics.intro_move (Some id) MoveLast ] +| [ "intro" ident(id) "at" "top" ] -> [ Tactics.intro_move (Some id) MoveFirst ] +| [ "intro" ident(id) "at" "bottom" ] -> [ Tactics.intro_move (Some id) MoveLast ] +| [ "intro" ident(id) "after" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveAfter h) ] +| [ "intro" ident(id) "before" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveBefore h) ] +| [ "intro" "at" "top" ] -> [ Tactics.intro_move None MoveFirst ] +| [ "intro" "at" "bottom" ] -> [ Tactics.intro_move None MoveLast ] +| [ "intro" "after" hyp(h) ] -> [ Tactics.intro_move None (MoveAfter h) ] +| [ "intro" "before" hyp(h) ] -> [ Tactics.intro_move None (MoveBefore h) ] +END + +(** Move *) + +TACTIC EXTEND move + [ "move" hyp(id) "at" "top" ] -> [ Tactics.move_hyp id MoveFirst ] +| [ "move" hyp(id) "at" "bottom" ] -> [ Tactics.move_hyp id MoveLast ] +| [ "move" hyp(id) "after" hyp(h) ] -> [ Tactics.move_hyp id (MoveAfter h) ] +| [ "move" hyp(id) "before" hyp(h) ] -> [ Tactics.move_hyp id (MoveBefore h) ] +END + +(** Rename *) + +TACTIC EXTEND rename +| [ "rename" ne_rename_list_sep(ids, ",") ] -> [ Tactics.rename_hyp ids ] +END + +(** Revert *) + +TACTIC EXTEND revert + [ "revert" ne_hyp_list(hl) ] -> [ Tactics.revert hl ] +END + +(** Simple induction / destruct *) + +TACTIC EXTEND simple_induction + [ "simple" "induction" quantified_hypothesis(h) ] -> [ Tactics.simple_induct h ] +END + +TACTIC EXTEND simple_destruct + [ "simple" "destruct" quantified_hypothesis(h) ] -> [ Tactics.simple_destruct h ] +END + +(** Double induction *) + +TACTIC EXTEND double_induction + [ "double" "induction" quantified_hypothesis(h1) quantified_hypothesis(h2) ] -> + [ Elim.h_double_induction h1 h2 ] +END + +(* Admit *) + +TACTIC EXTEND admit + [ "admit" ] -> [ Proofview.give_up ] +END + +(* Fix *) + +TACTIC EXTEND fix + [ "fix" natural(n) ] -> [ Tactics.fix None n ] +| [ "fix" ident(id) natural(n) ] -> [ Tactics.fix (Some id) n ] +END + +(* Cofix *) + +TACTIC EXTEND cofix + [ "cofix" ] -> [ Tactics.cofix None ] +| [ "cofix" ident(id) ] -> [ Tactics.cofix (Some id) ] +END + +(* Clear *) + +TACTIC EXTEND clear + [ "clear" hyp_list(ids) ] -> [ + if List.is_empty ids then Tactics.keep [] + else Tactics.clear ids + ] +| [ "clear" "-" ne_hyp_list(ids) ] -> [ Tactics.keep ids ] +END + +(* Clearbody *) + +TACTIC EXTEND clearbody + [ "clearbody" ne_hyp_list(ids) ] -> [ Tactics.clear_body ids ] +END + +(* Generalize dependent *) + +TACTIC EXTEND generalize_dependent + [ "generalize" "dependent" constr(c) ] -> [ Tactics.generalize_dep c ] +END + +(* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) + +open Tacexpr + +let initial_atomic () = + let dloc = Loc.ghost in + let nocl = {onhyps=Some[];concl_occs=AllOccurrences} in + let iter (s, t) = + let body = TacAtom (dloc, t) in + Tacenv.register_ltac false false (Id.of_string s) body + in + let () = List.iter iter + [ "red", TacReduce(Red false,nocl); + "hnf", TacReduce(Hnf,nocl); + "simpl", TacReduce(Simpl (Redops.all_flags,None),nocl); + "compute", TacReduce(Cbv Redops.all_flags,nocl); + "intros", TacIntroPattern (false,[]); + ] + in + let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in + List.iter iter + [ "idtac",TacId []; + "fail", TacFail(TacLocal,ArgArg 0,[]); + "fresh", TacArg(dloc,TacFreshId []) + ] + +let () = Mltop.declare_cache_obj initial_atomic "coretactics" diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml new file mode 100644 index 000000000..c5b26e6d5 --- /dev/null +++ b/plugins/ltac/evar_tactics.ml @@ -0,0 +1,93 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + let sigma = gl.sigma in + let evl = + match ido with + ConclLocation () -> evar_list (pf_concl gl) + | HypLocation (id,hloc) -> + let decl = Environ.lookup_named_val id (Goal.V82.hyps sigma (sig_it gl)) in + match hloc with + InHyp -> + (match decl with + | LocalAssum (_,typ) -> evar_list typ + | _ -> error + "Please be more specific: in type or value?") + | InHypTypeOnly -> + evar_list (NamedDecl.get_type decl) + | InHypValueOnly -> + (match decl with + | LocalDef (_,body,_) -> evar_list body + | _ -> error "Not a defined hypothesis.") in + if List.length evl < n then + error "Not enough uninstantiated existential variables."; + if n <= 0 then error "Incorrect existential variable index."; + let evk,_ = List.nth evl (n-1) in + instantiate_evar evk c sigma gl + end + +let instantiate_tac_by_name id c = + Proofview.V82.tactic begin fun gl -> + let sigma = gl.sigma in + let evk = + try Evd.evar_key id sigma + with Not_found -> error "Unknown existential variable." in + instantiate_evar evk c sigma gl + end + +let let_evar name typ = + let src = (Loc.ghost,Evar_kinds.GoalEvar) in + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Tacmach.New.project gl in + let env = Proofview.Goal.env gl in + let sigma = ref sigma in + let _ = Typing.e_sort_of env sigma typ in + let sigma = Sigma.Unsafe.of_evar_map !sigma in + let id = match name with + | Names.Anonymous -> + let id = Namegen.id_of_name_using_hdchar env typ name in + Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env)) + | Names.Name id -> id + in + let Sigma (evar, sigma, p) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in + let tac = + (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere) + in + Sigma (tac, sigma, p) + end } diff --git a/plugins/ltac/evar_tactics.mli b/plugins/ltac/evar_tactics.mli new file mode 100644 index 000000000..e67540c05 --- /dev/null +++ b/plugins/ltac/evar_tactics.mli @@ -0,0 +1,19 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Tacinterp.interp_sign * Glob_term.glob_constr -> + (Id.t * hyp_location_flag, unit) location -> unit Proofview.tactic + +val instantiate_tac_by_name : Id.t -> + Tacinterp.interp_sign * Glob_term.glob_constr -> unit Proofview.tactic + +val let_evar : Name.t -> Term.types -> unit Proofview.tactic diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4 new file mode 100644 index 000000000..53b726432 --- /dev/null +++ b/plugins/ltac/extraargs.ml4 @@ -0,0 +1,389 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* " + +let pr_orient _prc _prlc _prt = function + | true -> Pp.mt () + | false -> Pp.str " <-" + +ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient +| [ "->" ] -> [ true ] +| [ "<-" ] -> [ false ] +| [ ] -> [ true ] +END + +let pr_int _ _ _ i = Pp.int i + +let _natural = Pcoq.Prim.natural + +ARGUMENT EXTEND natural TYPED AS int PRINTED BY pr_int +| [ _natural(i) ] -> [ i ] +END + +let pr_orient = pr_orient () () () + + +let pr_int_list = Pp.pr_sequence Pp.int +let pr_int_list_full _prc _prlc _prt l = pr_int_list l + +let pr_occurrences _prc _prlc _prt l = + match l with + | ArgArg x -> pr_int_list x + | ArgVar (loc, id) -> Nameops.pr_id id + +let occurrences_of = function + | [] -> NoOccurrences + | n::_ as nl when n < 0 -> AllOccurrencesBut (List.map abs nl) + | nl -> + if List.exists (fun n -> n < 0) nl then + CErrors.error "Illegal negative occurrence number."; + OnlyOccurrences nl + +let coerce_to_int v = match Value.to_int v with + | None -> raise (CannotCoerceTo "an integer") + | Some n -> n + +let int_list_of_VList v = match Value.to_list v with +| Some l -> List.map (fun n -> coerce_to_int n) l +| _ -> raise (CannotCoerceTo "an integer") + +let interp_occs ist gl l = + match l with + | ArgArg x -> x + | ArgVar (_,id as locid) -> + (try int_list_of_VList (Id.Map.find id ist.lfun) + with Not_found | CannotCoerceTo _ -> [interp_int ist locid]) +let interp_occs ist gl l = + Tacmach.project gl , interp_occs ist gl l + +let glob_occs ist l = l + +let subst_occs evm l = l + +ARGUMENT EXTEND occurrences + TYPED AS int list + PRINTED BY pr_int_list_full + + INTERPRETED BY interp_occs + GLOBALIZED BY glob_occs + SUBSTITUTED BY subst_occs + + RAW_PRINTED BY pr_occurrences + GLOB_PRINTED BY pr_occurrences + +| [ ne_integer_list(l) ] -> [ ArgArg l ] +| [ var(id) ] -> [ ArgVar id ] +END + +let pr_occurrences = pr_occurrences () () () + +let pr_gen prc _prlc _prtac c = prc c + +let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob + +let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) + +let glob_glob = Tacintern.intern_constr + +let pr_lconstr _ prc _ c = prc c + +let subst_glob = Tacsubst.subst_glob_constr_and_expr + +ARGUMENT EXTEND glob + PRINTED BY pr_globc + + INTERPRETED BY interp_glob + GLOBALIZED BY glob_glob + SUBSTITUTED BY subst_glob + + RAW_PRINTED BY pr_gen + GLOB_PRINTED BY pr_gen + [ constr(c) ] -> [ c ] +END + +let l_constr = Pcoq.Constr.lconstr + +ARGUMENT EXTEND lconstr + TYPED AS constr + PRINTED BY pr_lconstr + [ l_constr(c) ] -> [ c ] +END + +ARGUMENT EXTEND lglob + TYPED AS glob + PRINTED BY pr_globc + + INTERPRETED BY interp_glob + GLOBALIZED BY glob_glob + SUBSTITUTED BY subst_glob + + RAW_PRINTED BY pr_gen + GLOB_PRINTED BY pr_gen + [ lconstr(c) ] -> [ c ] +END + +let interp_casted_constr ist gl c = + interp_constr_gen (Pretyping.OfType (pf_concl gl)) ist (pf_env gl) (project gl) c + +ARGUMENT EXTEND casted_constr + TYPED AS constr + PRINTED BY pr_gen + INTERPRETED BY interp_casted_constr + [ constr(c) ] -> [ c ] +END + +type 'id gen_place= ('id * hyp_location_flag,unit) location + +type loc_place = Id.t Loc.located gen_place +type place = Id.t gen_place + +let pr_gen_place pr_id = function + ConclLocation () -> Pp.mt () + | HypLocation (id,InHyp) -> str "in " ++ pr_id id + | HypLocation (id,InHypTypeOnly) -> + str "in (Type of " ++ pr_id id ++ str ")" + | HypLocation (id,InHypValueOnly) -> + str "in (Value of " ++ pr_id id ++ str ")" + +let pr_loc_place _ _ _ = pr_gen_place (fun (_,id) -> Nameops.pr_id id) +let pr_place _ _ _ = pr_gen_place Nameops.pr_id +let pr_hloc = pr_loc_place () () () + +let intern_place ist = function + ConclLocation () -> ConclLocation () + | HypLocation (id,hl) -> HypLocation (Tacintern.intern_hyp ist id,hl) + +let interp_place ist env sigma = function + ConclLocation () -> ConclLocation () + | HypLocation (id,hl) -> HypLocation (Tacinterp.interp_hyp ist env sigma id,hl) + +let interp_place ist gl p = + Tacmach.project gl , interp_place ist (Tacmach.pf_env gl) (Tacmach.project gl) p + +let subst_place subst pl = pl + +ARGUMENT EXTEND hloc + PRINTED BY pr_place + INTERPRETED BY interp_place + GLOBALIZED BY intern_place + SUBSTITUTED BY subst_place + RAW_PRINTED BY pr_loc_place + GLOB_PRINTED BY pr_loc_place + [ ] -> + [ ConclLocation () ] + | [ "in" "|-" "*" ] -> + [ ConclLocation () ] +| [ "in" ident(id) ] -> + [ HypLocation ((Loc.ghost,id),InHyp) ] +| [ "in" "(" "Type" "of" ident(id) ")" ] -> + [ HypLocation ((Loc.ghost,id),InHypTypeOnly) ] +| [ "in" "(" "Value" "of" ident(id) ")" ] -> + [ HypLocation ((Loc.ghost,id),InHypValueOnly) ] + + END + +let pr_rename _ _ _ (n, m) = Nameops.pr_id n ++ str " into " ++ Nameops.pr_id m + +ARGUMENT EXTEND rename + TYPED AS ident * ident + PRINTED BY pr_rename +| [ ident(n) "into" ident(m) ] -> [ (n, m) ] +END + +(* Julien: Mise en commun des differentes version de replace with in by *) + +let pr_by_arg_tac _prc _prlc prtac opt_c = + match opt_c with + | None -> mt () + | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Ppextend.E) t) + +ARGUMENT EXTEND by_arg_tac + TYPED AS tactic_opt + PRINTED BY pr_by_arg_tac +| [ "by" tactic3(c) ] -> [ Some c ] +| [ ] -> [ None ] +END + +let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c + +let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl +let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl +let in_clause' = Pltac.in_clause + +ARGUMENT EXTEND in_clause + TYPED AS clause_dft_concl + PRINTED BY pr_in_top_clause + RAW_TYPED AS clause_dft_concl + RAW_PRINTED BY pr_in_clause + GLOB_TYPED AS clause_dft_concl + GLOB_PRINTED BY pr_in_clause +| [ in_clause'(cl) ] -> [ cl ] +END + +(* spiwack: the print functions are incomplete, but I don't know what they are + used for *) +let pr_r_nat_field natf = + str "nat " ++ + match natf with + | Retroknowledge.NatType -> str "type" + | Retroknowledge.NatPlus -> str "plus" + | Retroknowledge.NatTimes -> str "times" + +let pr_r_n_field nf = + str "binary N " ++ + match nf with + | Retroknowledge.NPositive -> str "positive" + | Retroknowledge.NType -> str "type" + | Retroknowledge.NTwice -> str "twice" + | Retroknowledge.NTwicePlusOne -> str "twice plus one" + | Retroknowledge.NPhi -> str "phi" + | Retroknowledge.NPhiInv -> str "phi inv" + | Retroknowledge.NPlus -> str "plus" + | Retroknowledge.NTimes -> str "times" + +let pr_r_int31_field i31f = + str "int31 " ++ + match i31f with + | Retroknowledge.Int31Bits -> str "bits" + | Retroknowledge.Int31Type -> str "type" + | Retroknowledge.Int31Twice -> str "twice" + | Retroknowledge.Int31TwicePlusOne -> str "twice plus one" + | Retroknowledge.Int31Phi -> str "phi" + | Retroknowledge.Int31PhiInv -> str "phi inv" + | Retroknowledge.Int31Plus -> str "plus" + | Retroknowledge.Int31Times -> str "times" + | Retroknowledge.Int31Constructor -> assert false + | Retroknowledge.Int31PlusC -> str "plusc" + | Retroknowledge.Int31PlusCarryC -> str "pluscarryc" + | Retroknowledge.Int31Minus -> str "minus" + | Retroknowledge.Int31MinusC -> str "minusc" + | Retroknowledge.Int31MinusCarryC -> str "minuscarryc" + | Retroknowledge.Int31TimesC -> str "timesc" + | Retroknowledge.Int31Div21 -> str "div21" + | Retroknowledge.Int31Div -> str "div" + | Retroknowledge.Int31Diveucl -> str "diveucl" + | Retroknowledge.Int31AddMulDiv -> str "addmuldiv" + | Retroknowledge.Int31Compare -> str "compare" + | Retroknowledge.Int31Head0 -> str "head0" + | Retroknowledge.Int31Tail0 -> str "tail0" + | Retroknowledge.Int31Lor -> str "lor" + | Retroknowledge.Int31Land -> str "land" + | Retroknowledge.Int31Lxor -> str "lxor" + +let pr_retroknowledge_field f = + match f with + (* | Retroknowledge.KEq -> str "equality" + | Retroknowledge.KNat natf -> pr_r_nat_field () () () natf + | Retroknowledge.KN nf -> pr_r_n_field () () () nf *) + | Retroknowledge.KInt31 (group, i31f) -> (pr_r_int31_field i31f) ++ + spc () ++ str "in " ++ qs group + +VERNAC ARGUMENT EXTEND retroknowledge_nat +PRINTED BY pr_r_nat_field +| [ "nat" "type" ] -> [ Retroknowledge.NatType ] +| [ "nat" "plus" ] -> [ Retroknowledge.NatPlus ] +| [ "nat" "times" ] -> [ Retroknowledge.NatTimes ] +END + + +VERNAC ARGUMENT EXTEND retroknowledge_binary_n +PRINTED BY pr_r_n_field +| [ "binary" "N" "positive" ] -> [ Retroknowledge.NPositive ] +| [ "binary" "N" "type" ] -> [ Retroknowledge.NType ] +| [ "binary" "N" "twice" ] -> [ Retroknowledge.NTwice ] +| [ "binary" "N" "twice" "plus" "one" ] -> [ Retroknowledge.NTwicePlusOne ] +| [ "binary" "N" "phi" ] -> [ Retroknowledge.NPhi ] +| [ "binary" "N" "phi" "inv" ] -> [ Retroknowledge.NPhiInv ] +| [ "binary" "N" "plus" ] -> [ Retroknowledge.NPlus ] +| [ "binary" "N" "times" ] -> [ Retroknowledge.NTimes ] +END + +VERNAC ARGUMENT EXTEND retroknowledge_int31 +PRINTED BY pr_r_int31_field +| [ "int31" "bits" ] -> [ Retroknowledge.Int31Bits ] +| [ "int31" "type" ] -> [ Retroknowledge.Int31Type ] +| [ "int31" "twice" ] -> [ Retroknowledge.Int31Twice ] +| [ "int31" "twice" "plus" "one" ] -> [ Retroknowledge.Int31TwicePlusOne ] +| [ "int31" "phi" ] -> [ Retroknowledge.Int31Phi ] +| [ "int31" "phi" "inv" ] -> [ Retroknowledge.Int31PhiInv ] +| [ "int31" "plus" ] -> [ Retroknowledge.Int31Plus ] +| [ "int31" "plusc" ] -> [ Retroknowledge.Int31PlusC ] +| [ "int31" "pluscarryc" ] -> [ Retroknowledge.Int31PlusCarryC ] +| [ "int31" "minus" ] -> [ Retroknowledge.Int31Minus ] +| [ "int31" "minusc" ] -> [ Retroknowledge.Int31MinusC ] +| [ "int31" "minuscarryc" ] -> [ Retroknowledge.Int31MinusCarryC ] +| [ "int31" "times" ] -> [ Retroknowledge.Int31Times ] +| [ "int31" "timesc" ] -> [ Retroknowledge.Int31TimesC ] +| [ "int31" "div21" ] -> [ Retroknowledge.Int31Div21 ] +| [ "int31" "div" ] -> [ Retroknowledge.Int31Div ] +| [ "int31" "diveucl" ] -> [ Retroknowledge.Int31Diveucl ] +| [ "int31" "addmuldiv" ] -> [ Retroknowledge.Int31AddMulDiv ] +| [ "int31" "compare" ] -> [ Retroknowledge.Int31Compare ] +| [ "int31" "head0" ] -> [ Retroknowledge.Int31Head0 ] +| [ "int31" "tail0" ] -> [ Retroknowledge.Int31Tail0 ] +| [ "int31" "lor" ] -> [ Retroknowledge.Int31Lor ] +| [ "int31" "land" ] -> [ Retroknowledge.Int31Land ] +| [ "int31" "lxor" ] -> [ Retroknowledge.Int31Lxor ] +END + +VERNAC ARGUMENT EXTEND retroknowledge_field +PRINTED BY pr_retroknowledge_field +(*| [ "equality" ] -> [ Retroknowledge.KEq ] +| [ retroknowledge_nat(n)] -> [ Retroknowledge.KNat n ] +| [ retroknowledge_binary_n (n)] -> [ Retroknowledge.KN n ]*) +| [ retroknowledge_int31 (i) "in" string(g)] -> [ Retroknowledge.KInt31(g,i) ] +END diff --git a/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli new file mode 100644 index 000000000..b12187e18 --- /dev/null +++ b/plugins/ltac/extraargs.mli @@ -0,0 +1,78 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Pp.std_ppcmds + +val wit_rename : (Id.t * Id.t) Genarg.uniform_genarg_type + +val occurrences : (int list or_var) Pcoq.Gram.entry +val wit_occurrences : (int list or_var, int list or_var, int list) Genarg.genarg_type +val pr_occurrences : int list or_var -> Pp.std_ppcmds +val occurrences_of : int list -> Locus.occurrences + +val wit_natural : int Genarg.uniform_genarg_type + +val wit_glob : + (constr_expr, + Tacexpr.glob_constr_and_expr, + Tacinterp.interp_sign * glob_constr) Genarg.genarg_type + +val wit_lglob : + (constr_expr, + Tacexpr.glob_constr_and_expr, + Tacinterp.interp_sign * glob_constr) Genarg.genarg_type + +val wit_lconstr : + (constr_expr, + Tacexpr.glob_constr_and_expr, + Constr.t) Genarg.genarg_type + +val wit_casted_constr : + (constr_expr, + Tacexpr.glob_constr_and_expr, + Constr.t) Genarg.genarg_type + +val glob : constr_expr Pcoq.Gram.entry +val lglob : constr_expr Pcoq.Gram.entry + +type 'id gen_place= ('id * Locus.hyp_location_flag,unit) location + +type loc_place = Id.t Loc.located gen_place +type place = Id.t gen_place + +val wit_hloc : (loc_place, loc_place, place) Genarg.genarg_type +val hloc : loc_place Pcoq.Gram.entry +val pr_hloc : loc_place -> Pp.std_ppcmds + +val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry +val wit_by_arg_tac : + (raw_tactic_expr option, + glob_tactic_expr option, + Geninterp.Val.t option) Genarg.genarg_type + +val pr_by_arg_tac : + (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) -> + raw_tactic_expr option -> Pp.std_ppcmds + +(** Spiwack: Primitive for retroknowledge registration *) + +val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry +val wit_retroknowledge_field : (Retroknowledge.field, unit, unit) Genarg.genarg_type + +val wit_in_clause : + (Id.t Loc.located Locus.clause_expr, + Id.t Loc.located Locus.clause_expr, + Id.t Locus.clause_expr) Genarg.genarg_type diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 new file mode 100644 index 000000000..1223f6eb4 --- /dev/null +++ b/plugins/ltac/extratactics.ml4 @@ -0,0 +1,1097 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* replace_in_clause_maybe_by c1 c2 cl (Option.map (Tacinterp.tactic_of_value ist) tac)) + +let replace_term ist dir_opt c cl = + with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl) + +let clause = Pltac.clause_dft_concl + +TACTIC EXTEND replace + ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] +-> [ replace_in_clause_maybe_by ist c1 c2 cl tac ] +END + +TACTIC EXTEND replace_term_left + [ "replace" "->" uconstr(c) clause(cl) ] + -> [ replace_term ist (Some true) c cl ] +END + +TACTIC EXTEND replace_term_right + [ "replace" "<-" uconstr(c) clause(cl) ] + -> [ replace_term ist (Some false) c cl ] +END + +TACTIC EXTEND replace_term + [ "replace" uconstr(c) clause(cl) ] + -> [ replace_term ist None c cl ] +END + +let induction_arg_of_quantified_hyp = function + | AnonHyp n -> None,ElimOnAnonHyp n + | NamedHyp id -> None,ElimOnIdent (Loc.ghost,id) + +(* Versions *_main must come first!! so that "1" is interpreted as a + ElimOnAnonHyp and not as a "constr", and "id" is interpreted as a + ElimOnIdent and not as "constr" *) + +let mytclWithHoles tac with_evars c = + Proofview.Goal.enter { enter = begin fun gl -> + let env = Tacmach.New.pf_env gl in + let sigma = Tacmach.New.project gl in + let sigma',c = Tactics.force_destruction_arg with_evars env sigma c in + Tacticals.New.tclWITHHOLES with_evars (tac with_evars (Some c)) sigma' + end } + +let elimOnConstrWithHoles tac with_evars c = + Tacticals.New.tclDELAYEDWITHHOLES with_evars c + (fun c -> tac with_evars (Some (None,ElimOnConstr c))) + +TACTIC EXTEND simplify_eq + [ "simplify_eq" ] -> [ dEq false None ] +| [ "simplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq false c ] +END +TACTIC EXTEND esimplify_eq +| [ "esimplify_eq" ] -> [ dEq true None ] +| [ "esimplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq true c ] +END + +let discr_main c = elimOnConstrWithHoles discr_tac false c + +TACTIC EXTEND discriminate +| [ "discriminate" ] -> [ discr_tac false None ] +| [ "discriminate" destruction_arg(c) ] -> + [ mytclWithHoles discr_tac false c ] +END +TACTIC EXTEND ediscriminate +| [ "ediscriminate" ] -> [ discr_tac true None ] +| [ "ediscriminate" destruction_arg(c) ] -> + [ mytclWithHoles discr_tac true c ] +END + +let discrHyp id = + Proofview.tclEVARMAP >>= fun sigma -> + discr_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } + +let injection_main with_evars c = + elimOnConstrWithHoles (injClause None) with_evars c + +TACTIC EXTEND injection +| [ "injection" ] -> [ injClause None false None ] +| [ "injection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) false c ] +END +TACTIC EXTEND einjection +| [ "einjection" ] -> [ injClause None true None ] +| [ "einjection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) true c ] +END +TACTIC EXTEND injection_as +| [ "injection" "as" intropattern_list(ipat)] -> + [ injClause (Some ipat) false None ] +| [ "injection" destruction_arg(c) "as" intropattern_list(ipat)] -> + [ mytclWithHoles (injClause (Some ipat)) false c ] +END +TACTIC EXTEND einjection_as +| [ "einjection" "as" intropattern_list(ipat)] -> + [ injClause (Some ipat) true None ] +| [ "einjection" destruction_arg(c) "as" intropattern_list(ipat)] -> + [ mytclWithHoles (injClause (Some ipat)) true c ] +END +TACTIC EXTEND simple_injection +| [ "simple" "injection" ] -> [ simpleInjClause false None ] +| [ "simple" "injection" destruction_arg(c) ] -> [ mytclWithHoles simpleInjClause false c ] +END + +let injHyp id = + Proofview.tclEVARMAP >>= fun sigma -> + injection_main false { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } + +TACTIC EXTEND dependent_rewrite +| [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] +| [ "dependent" "rewrite" orient(b) constr(c) "in" hyp(id) ] + -> [ rewriteInHyp b c id ] +END + +(** To be deprecated?, "cutrewrite (t=u) as <-" is equivalent to + "replace u with t" or "enough (t=u) as <-" and + "cutrewrite (t=u) as ->" is equivalent to "enough (t=u) as ->". *) + +TACTIC EXTEND cut_rewrite +| [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ] +| [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] + -> [ cutRewriteInHyp b eqn id ] +END + +(**********************************************************************) +(* Decompose *) + +TACTIC EXTEND decompose_sum +| [ "decompose" "sum" constr(c) ] -> [ Elim.h_decompose_or c ] +END + +TACTIC EXTEND decompose_record +| [ "decompose" "record" constr(c) ] -> [ Elim.h_decompose_and c ] +END + +(**********************************************************************) +(* Contradiction *) + +open Contradiction + +TACTIC EXTEND absurd + [ "absurd" constr(c) ] -> [ absurd c ] +END + +let onSomeWithHoles tac = function + | None -> tac None + | Some c -> Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> tac (Some c)) + +TACTIC EXTEND contradiction + [ "contradiction" constr_with_bindings_opt(c) ] -> + [ onSomeWithHoles contradiction c ] +END + +(**********************************************************************) +(* AutoRewrite *) + +open Autorewrite + +let pr_orient _prc _prlc _prt = function + | true -> Pp.mt () + | false -> Pp.str " <-" + +let pr_orient_string _prc _prlc _prt (orient, s) = + pr_orient _prc _prlc _prt orient ++ Pp.spc () ++ Pp.str s + +ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_string +| [ orient(r) preident(i) ] -> [ r, i ] +END + +TACTIC EXTEND autorewrite +| [ "autorewrite" "with" ne_preident_list(l) clause(cl) ] -> + [ auto_multi_rewrite l ( cl) ] +| [ "autorewrite" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> + [ + auto_multi_rewrite_with (Tacinterp.tactic_of_value ist t) l cl + ] +END + +TACTIC EXTEND autorewrite_star +| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) ] -> + [ auto_multi_rewrite ~conds:AllMatches l cl ] +| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> + [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.tactic_of_value ist t) l cl ] +END + +(**********************************************************************) +(* Rewrite star *) + +let rewrite_star ist clause orient occs c (tac : Geninterp.Val.t option) = + let tac' = Option.map (fun t -> Tacinterp.tactic_of_value ist t, FirstSolved) tac in + with_delayed_uconstr ist c + (fun c -> general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) + +TACTIC EXTEND rewrite_star +| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o Locus.AllOccurrences c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> + [ rewrite_star ist None o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) by_arg_tac(tac) ] -> + [ rewrite_star ist None o Locus.AllOccurrences c tac ] + END + +(**********************************************************************) +(* Hint Rewrite *) + +let add_rewrite_hint 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 c, ctx = Constrintern.interp_constr env sigma ce in + let ctx = + let ctx = UState.context_set ctx in + if poly then ctx + else (** This is a global universe context that shouldn't be + refreshed at every use of the hint, declare it globally. *) + (Declare.declare_universe_context false ctx; + Univ.ContextSet.empty) + in + Constrexpr_ops.constr_loc ce, (c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t in + let eqs = List.map f lcsr in + let add_hints base = add_rew_rules base eqs in + List.iter add_hints bases + +let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater + +VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY classify_hint + [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> + [ add_rewrite_hint bl o None l ] +| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) + ":" preident_list(bl) ] -> + [ add_rewrite_hint bl o (Some t) l ] +| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> + [ add_rewrite_hint ["core"] o None l ] +| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> + [ add_rewrite_hint ["core"] o (Some t) l ] +END + +(**********************************************************************) +(* Hint Resolve *) + +open Term +open Vars +open Coqlib + +let project_hint pri l2r r = + let gr = Smartlocate.global_with_alias r in + let env = Global.env() in + let sigma = Evd.from_env env in + let sigma, c = Evd.fresh_global env sigma gr in + let t = Retyping.get_type_of env sigma c in + let t = + Tacred.reduce_to_quantified_ref env sigma (Lazy.force coq_iff_ref) t in + let sign,ccl = decompose_prod_assum t in + let (a,b) = match snd (decompose_app ccl) with + | [a;b] -> (a,b) + | _ -> assert false in + let p = + if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in + let c = Reductionops.whd_beta Evd.empty (mkApp (c, Context.Rel.to_extended_vect 0 sign)) in + let c = it_mkLambda_or_LetIn + (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in + let id = + Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) + in + let ctx = Evd.universe_context_set sigma 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 l2r lc n bl = + let l = Locality.LocalityFixme.consume () in + Hints.add_hints (Locality.make_module_locality l) bl + (Hints.HintsResolveEntry (List.map (project_hint n l2r) lc)) + +VERNAC COMMAND EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF + [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) + ":" preident_list(bl) ] -> + [ add_hints_iff true lc n bl ] +| [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ] -> + [ add_hints_iff true lc n ["core"] ] +END +VERNAC COMMAND EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF + [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) + ":" preident_list(bl) ] -> + [ add_hints_iff false lc n bl ] +| [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ] -> + [ add_hints_iff false lc n ["core"] ] +END + +(**********************************************************************) +(* Refine *) + +let constr_flags = { + Pretyping.use_typeclasses = true; + Pretyping.solve_unification_constraints = true; + Pretyping.use_hook = Some Pfedit.solve_by_implicit_tactic; + Pretyping.fail_evar = false; + Pretyping.expand_evars = true } + +let refine_tac ist simple with_classes c = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let flags = + { constr_flags with Pretyping.use_typeclasses = with_classes } in + let expected_type = Pretyping.OfType concl in + let c = Pretyping.type_uconstr ~flags ~expected_type ist c in + let update = { run = fun sigma -> c.delayed env sigma } in + let refine = Refine.refine ~unsafe:true update in + if simple then refine + else refine <*> + Tactics.New.reduce_after_refine <*> + Proofview.shelve_unifiable + end } + +TACTIC EXTEND refine +| [ "refine" uconstr(c) ] -> + [ refine_tac ist false true c ] +END + +TACTIC EXTEND simple_refine +| [ "simple" "refine" uconstr(c) ] -> + [ refine_tac ist true true c ] +END + +TACTIC EXTEND notcs_refine +| [ "notypeclasses" "refine" uconstr(c) ] -> + [ refine_tac ist false false c ] +END + +TACTIC EXTEND notcs_simple_refine +| [ "simple" "notypeclasses" "refine" uconstr(c) ] -> + [ refine_tac ist true false c ] +END + +(* Solve unification constraints using heuristics or fail if any remain *) +TACTIC EXTEND solve_constraints +[ "solve_constraints" ] -> [ Refine.solve_constraints ] +END + +(**********************************************************************) +(* Inversion lemmas (Leminv) *) + +open Inv +open Leminv + +let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater + +VERNAC ARGUMENT EXTEND sort +| [ "Set" ] -> [ GSet ] +| [ "Prop" ] -> [ GProp ] +| [ "Type" ] -> [ GType [] ] +END + +VERNAC COMMAND EXTEND DeriveInversionClear +| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] + => [ seff na ] + -> [ add_inversion_lemma_exn na c s false inv_clear_tac ] + +| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ] + -> [ add_inversion_lemma_exn na c GProp false inv_clear_tac ] +END + +open Term + +VERNAC COMMAND EXTEND DeriveInversion +| [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] + => [ seff na ] + -> [ add_inversion_lemma_exn na c s false inv_tac ] + +| [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ] + -> [ add_inversion_lemma_exn na c GProp false inv_tac ] +END + +VERNAC COMMAND EXTEND DeriveDependentInversion +| [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] + => [ seff na ] + -> [ add_inversion_lemma_exn na c s true dinv_tac ] +END + +VERNAC COMMAND EXTEND DeriveDependentInversionClear +| [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] + => [ seff na ] + -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ] +END + +(**********************************************************************) +(* Subst *) + +TACTIC EXTEND subst +| [ "subst" ne_var_list(l) ] -> [ subst l ] +| [ "subst" ] -> [ subst_all () ] +END + +let simple_subst_tactic_flags = + { only_leibniz = true; rewrite_dependent_proof = false } + +TACTIC EXTEND simple_subst +| [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags () ] +END + +open Evar_tactics + +(**********************************************************************) +(* Evar creation *) + +(* TODO: add support for some test similar to g_constr.name_colon so that + expressions like "evar (list A)" do not raise a syntax error *) +TACTIC EXTEND evar + [ "evar" "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name id) typ ] +| [ "evar" constr(typ) ] -> [ let_evar Anonymous typ ] +END + +TACTIC EXTEND instantiate + [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] -> + [ Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals ] +| [ "instantiate" "(" integer(i) ":=" lglob(c) ")" hloc(hl) ] -> + [ Tacticals.New.tclTHEN (instantiate_tac i c hl) Proofview.V82.nf_evar_goals ] +| [ "instantiate" ] -> [ Proofview.V82.nf_evar_goals ] +END + +(**********************************************************************) +(** Nijmegen "step" tactic for setoid rewriting *) + +open Tactics +open Glob_term +open Libobject +open Lib + +(* Registered lemmas are expected to be of the form + x R y -> y == z -> x R z (in the right table) + x R y -> x == z -> z R y (in the left table) +*) + +let transitivity_right_table = Summary.ref [] ~name:"transitivity-steps-r" +let transitivity_left_table = Summary.ref [] ~name:"transitivity-steps-l" + +(* [step] tries to apply a rewriting lemma; then apply [tac] intended to + complete to proof of the last hypothesis (assumed to state an equality) *) + +let step left x tac = + let l = + List.map (fun lem -> + Tacticals.New.tclTHENLAST + (apply_with_bindings (lem, ImplicitBindings [x])) + tac) + !(if left then transitivity_left_table else transitivity_right_table) + in + Tacticals.New.tclFIRST l + +(* Main function to push lemmas in persistent environment *) + +let cache_transitivity_lemma (_,(left,lem)) = + if left then + transitivity_left_table := lem :: !transitivity_left_table + else + transitivity_right_table := lem :: !transitivity_right_table + +let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref) + +let inTransitivity : bool * constr -> obj = + declare_object {(default_object "TRANSITIVITY-STEPS") with + cache_function = cache_transitivity_lemma; + open_function = (fun i o -> if Int.equal i 1 then cache_transitivity_lemma o); + subst_function = subst_transitivity_lemma; + classify_function = (fun o -> Substitute o) } + +(* Main entry points *) + +let add_transitivity_lemma left lem = + let env = Global.env () in + let sigma = Evd.from_env env in + let lem',ctx (*FIXME*) = Constrintern.interp_constr env sigma lem in + add_anonymous_leaf (inTransitivity (left,lem')) + +(* Vernacular syntax *) + +TACTIC EXTEND stepl +| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.tactic_of_value ist tac) ] +| ["stepl" constr(c) ] -> [ step true c (Proofview.tclUNIT ()) ] +END + +TACTIC EXTEND stepr +| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.tactic_of_value ist tac) ] +| ["stepr" constr(c) ] -> [ step false c (Proofview.tclUNIT ()) ] +END + +VERNAC COMMAND EXTEND AddStepl CLASSIFIED AS SIDEFF +| [ "Declare" "Left" "Step" constr(t) ] -> + [ add_transitivity_lemma true t ] +END + +VERNAC COMMAND EXTEND AddStepr CLASSIFIED AS SIDEFF +| [ "Declare" "Right" "Step" constr(t) ] -> + [ add_transitivity_lemma false t ] +END + +let cache_implicit_tactic (_,tac) = match tac with + | Some tac -> Pfedit.declare_implicit_tactic (Tacinterp.eval_tactic tac) + | None -> Pfedit.clear_implicit_tactic () + +let subst_implicit_tactic (subst,tac) = + Option.map (Tacsubst.subst_tactic subst) tac + +let inImplicitTactic : glob_tactic_expr option -> obj = + declare_object {(default_object "IMPLICIT-TACTIC") with + open_function = (fun i o -> if Int.equal i 1 then cache_implicit_tactic o); + cache_function = cache_implicit_tactic; + subst_function = subst_implicit_tactic; + classify_function = (fun o -> Dispose)} + +let declare_implicit_tactic tac = + Lib.add_anonymous_leaf (inImplicitTactic (Some (Tacintern.glob_tactic tac))) + +let clear_implicit_tactic () = + Lib.add_anonymous_leaf (inImplicitTactic None) + +VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF +| [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> [ declare_implicit_tactic tac ] +| [ "Clear" "Implicit" "Tactic" ] -> [ clear_implicit_tactic () ] +END + + + + +(**********************************************************************) +(*spiwack : Vernac commands for retroknowledge *) + +VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF + | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> + [ let tc,ctx = Constrintern.interp_constr (Global.env ()) Evd.empty c in + let tb,ctx(*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty b in + Global.register f tc tb ] +END + + + +(**********************************************************************) +(* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as + defined by Conor McBride *) +TACTIC EXTEND generalize_eqs +| ["generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false id ] +END +TACTIC EXTEND dep_generalize_eqs +| ["dependent" "generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false ~force_dep:true id ] +END +TACTIC EXTEND generalize_eqs_vars +| ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~generalize_vars:true id ] +END +TACTIC EXTEND dep_generalize_eqs_vars +| ["dependent" "generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~force_dep:true ~generalize_vars:true id ] +END + +(** Tactic to automatically simplify hypotheses of the form [Π Δ, x_i = t_i -> T] + where [t_i] is closed w.r.t. Δ. Such hypotheses are automatically generated + during dependent induction. For internal use. *) + +TACTIC EXTEND specialize_eqs +[ "specialize_eqs" hyp(id) ] -> [ specialize_eqs id ] +END + +(**********************************************************************) +(* A tactic that considers a given occurrence of [c] in [t] and *) +(* abstract the minimal set of all the occurrences of [c] so that the *) +(* abstraction [fun x -> t[x/c]] is well-typed *) +(* *) +(* Contributed by Chung-Kil Hur (Winter 2009) *) +(**********************************************************************) + +let subst_var_with_hole occ tid t = + let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in + let locref = ref 0 in + let rec substrec = function + | GVar (_,id) as x -> + if Id.equal id tid + then + (decr occref; + if Int.equal !occref 0 then x + else + (incr locref; + GHole (Loc.make_loc (!locref,0), + Evar_kinds.QuestionMark(Evar_kinds.Define true), + Misctypes.IntroAnonymous, None))) + else x + | c -> map_glob_constr_left_to_right substrec c in + let t' = substrec t + in + if !occref > 0 then Find_subterm.error_invalid_occurrence [occ] else t' + +let subst_hole_with_term occ tc t = + let locref = ref 0 in + let occref = ref occ in + let rec substrec = function + | GHole (_,Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s) -> + decr occref; + if Int.equal !occref 0 then tc + else + (incr locref; + GHole (Loc.make_loc (!locref,0), + Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s)) + | c -> map_glob_constr_left_to_right substrec c + in + substrec t + +open Tacmach + +let hResolve id c occ t = + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in + let env = Termops.clear_named_body id (Proofview.Goal.env gl) in + let concl = Proofview.Goal.concl gl in + let env_ids = Termops.ids_of_context env in + let c_raw = Detyping.detype true env_ids env sigma c in + let t_raw = Detyping.detype true env_ids env sigma t in + let rec resolve_hole t_hole = + try + Pretyping.understand env sigma t_hole + with + | Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _) as e -> + let (e, info) = CErrors.push e in + let loc = match Loc.get_loc info with None -> Loc.ghost | Some loc -> loc in + resolve_hole (subst_hole_with_term (fst (Loc.unloc loc)) c_raw t_hole) + in + let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in + let sigma = Evd.merge_universe_context sigma ctx in + let t_constr_type = Retyping.get_type_of env sigma t_constr in + let tac = + (change_concl (mkLetIn (Anonymous,t_constr,t_constr_type,concl))) + in + Sigma.Unsafe.of_pair (tac, sigma) + end } + +let hResolve_auto id c t = + let rec resolve_auto n = + try + hResolve id c n t + with + | UserError _ as e -> raise e + | e when CErrors.noncritical e -> resolve_auto (n+1) + in + resolve_auto 1 + +TACTIC EXTEND hresolve_core +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c occ t ] +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> [ hResolve_auto id c t ] +END + +(** + hget_evar +*) + +let hget_evar n = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let sigma = Tacmach.New.project gl in + let concl = Proofview.Goal.concl gl in + let evl = evar_list concl in + if List.length evl < n then + error "Not enough uninstantiated existential variables."; + if n <= 0 then error "Incorrect existential variable index."; + let ev = List.nth evl (n-1) in + let ev_type = existential_type sigma ev in + change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl)) + end } + +TACTIC EXTEND hget_evar +| [ "hget_evar" int_or_var(n) ] -> [ hget_evar n ] +END + +(**********************************************************************) + +(**********************************************************************) +(* A tactic that reduces one match t with ... by doing destruct t. *) +(* if t is not a variable, the tactic does *) +(* case_eq t;intros ... heq;rewrite heq in *|-. (but heq itself is *) +(* preserved). *) +(* Contributed by Julien Forest and Pierre Courtieu (july 2010) *) +(**********************************************************************) + +exception Found of unit Proofview.tactic + +let rewrite_except h = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let hyps = Tacmach.New.pf_ids_of_hyps gl in + Tacticals.New.tclMAP (fun id -> if Id.equal id h then Proofview.tclUNIT () else + Tacticals.New.tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true true id (mkVar h) false)) + hyps + end } + + +let refl_equal = + let coq_base_constant s = + Coqlib.gen_constant_in_modules "RecursiveDefinition" + (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s in + function () -> (coq_base_constant "eq_refl") + + +(* This is simply an implementation of the case_eq tactic. this code + should be replaced by a call to the tactic but I don't know how to + call it before it is defined. *) +let mkCaseEq a : unit Proofview.tactic = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let type_of_a = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g a) gl in + Tacticals.New.tclTHENLIST + [Tactics.generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]; + Proofview.Goal.nf_enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + (** FIXME: this looks really wrong. Does anybody really use this tactic? *) + let Sigma (c, _, _) = (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a]).Reductionops.e_redfun env (Sigma.Unsafe.of_evar_map Evd.empty) concl in + change_concl c + end }; + simplest_case a] + end } + + +let case_eq_intros_rewrite x = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let n = nb_prod (Proofview.Goal.concl gl) in + (* Pp.msgnl (Printer.pr_lconstr x); *) + Tacticals.New.tclTHENLIST [ + mkCaseEq x; + Proofview.Goal.nf_enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let hyps = Tacmach.New.pf_ids_of_hyps gl in + let n' = nb_prod concl in + let h = Tacmach.New.of_old (fun g -> fresh_id hyps (Id.of_string "heq") g) gl in + Tacticals.New.tclTHENLIST [ + Tacticals.New.tclDO (n'-n-1) intro; + introduction h; + rewrite_except h] + end } + ] + end } + +let rec find_a_destructable_match t = + let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in + let cl = [cl, (None, None), None], None in + let dest = TacAtom (Loc.ghost, TacInductionDestruct(false, false, cl)) in + match kind_of_term t with + | Case (_,_,x,_) when closed0 x -> + if isVar x then + (* TODO check there is no rel n. *) + raise (Found (Tacinterp.eval_tactic dest)) + else + (* let _ = Pp.msgnl (Printer.pr_lconstr x) in *) + raise (Found (case_eq_intros_rewrite x)) + | _ -> iter_constr find_a_destructable_match t + + +let destauto t = + try find_a_destructable_match t; + Tacticals.New.tclZEROMSG (str "No destructable match found") + with Found tac -> tac + +let destauto_in id = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let ctype = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g (mkVar id)) gl in +(* Pp.msgnl (Printer.pr_lconstr (mkVar id)); *) +(* Pp.msgnl (Printer.pr_lconstr (ctype)); *) + destauto ctype + end } + +TACTIC EXTEND destauto +| [ "destauto" ] -> [ Proofview.Goal.nf_enter { enter = begin fun gl -> destauto (Proofview.Goal.concl gl) end } ] +| [ "destauto" "in" hyp(id) ] -> [ destauto_in id ] +END + + +(* ********************************************************************* *) + +let eq_constr x y = + Proofview.Goal.enter { enter = begin fun gl -> + let evd = Tacmach.New.project gl in + if Evarutil.eq_constr_univs_test evd evd x y then Proofview.tclUNIT () + else Tacticals.New.tclFAIL 0 (str "Not equal") + end } + +TACTIC EXTEND constr_eq +| [ "constr_eq" constr(x) constr(y) ] -> [ eq_constr x y ] +END + +TACTIC EXTEND constr_eq_nounivs +| [ "constr_eq_nounivs" constr(x) constr(y) ] -> [ + if eq_constr_nounivs x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ] +END + +TACTIC EXTEND is_evar +| [ "is_evar" constr(x) ] -> + [ Proofview.tclBIND Proofview.tclEVARMAP begin fun sigma -> + match Evarutil.kind_of_term_upto sigma x with + | Evar _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (str "Not an evar") + end + ] +END + +let rec has_evar x = + match kind_of_term x with + | Evar _ -> true + | Rel _ | Var _ | Meta _ | Sort _ | Const _ | Ind _ | Construct _ -> + false + | Cast (t1, _, t2) | Prod (_, t1, t2) | Lambda (_, t1, t2) -> + has_evar t1 || has_evar t2 + | LetIn (_, t1, t2, t3) -> + has_evar t1 || has_evar t2 || has_evar t3 + | App (t1, ts) -> + has_evar t1 || has_evar_array ts + | Case (_, t1, t2, ts) -> + has_evar t1 || has_evar t2 || has_evar_array ts + | Fix ((_, tr)) | CoFix ((_, tr)) -> + has_evar_prec tr + | Proj (p, c) -> has_evar c +and has_evar_array x = + Array.exists has_evar x +and has_evar_prec (_, ts1, ts2) = + Array.exists has_evar ts1 || Array.exists has_evar ts2 + +TACTIC EXTEND has_evar +| [ "has_evar" constr(x) ] -> + [ if has_evar x then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "No evars") ] +END + +TACTIC EXTEND is_hyp +| [ "is_var" constr(x) ] -> + [ match kind_of_term x with + | Var _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (str "Not a variable or hypothesis") ] +END + +TACTIC EXTEND is_fix +| [ "is_fix" constr(x) ] -> + [ match kind_of_term x with + | Fix _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a fix definition") ] +END;; + +TACTIC EXTEND is_cofix +| [ "is_cofix" constr(x) ] -> + [ match kind_of_term x with + | CoFix _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") ] +END;; + +TACTIC EXTEND is_ind +| [ "is_ind" constr(x) ] -> + [ match kind_of_term x with + | Ind _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not an (co)inductive datatype") ] +END;; + +TACTIC EXTEND is_constructor +| [ "is_constructor" constr(x) ] -> + [ match kind_of_term x with + | Construct _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constructor") ] +END;; + +TACTIC EXTEND is_proj +| [ "is_proj" constr(x) ] -> + [ match kind_of_term x with + | Proj _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a primitive projection") ] +END;; + +TACTIC EXTEND is_const +| [ "is_const" constr(x) ] -> + [ match kind_of_term x with + | Const _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constant") ] +END;; + +(* Command to grab the evars left unresolved at the end of a proof. *) +(* spiwack: I put it in extratactics because it is somewhat tied with + the semantics of the LCF-style tactics, hence with the classic tactic + mode. *) +VERNAC COMMAND EXTEND GrabEvars +[ "Grab" "Existential" "Variables" ] + => [ Vernac_classifier.classify_as_proofstep ] + -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) ] +END + +(* Shelves all the goals under focus. *) +TACTIC EXTEND shelve +| [ "shelve" ] -> + [ Proofview.shelve ] +END + +(* Shelves the unifiable goals under focus, i.e. the goals which + appear in other goals under focus (the unfocused goals are not + considered). *) +TACTIC EXTEND shelve_unifiable +| [ "shelve_unifiable" ] -> + [ Proofview.shelve_unifiable ] +END + +(* Unshelves the goal shelved by the tactic. *) +TACTIC EXTEND unshelve +| [ "unshelve" tactic1(t) ] -> + [ + Proofview.with_shelf (Tacinterp.tactic_of_value ist t) >>= fun (gls, ()) -> + Proofview.Unsafe.tclGETGOALS >>= fun ogls -> + Proofview.Unsafe.tclSETGOALS (gls @ ogls) + ] +END + +(* Command to add every unshelved variables to the focus *) +VERNAC COMMAND EXTEND Unshelve +[ "Unshelve" ] + => [ Vernac_classifier.classify_as_proofstep ] + -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) ] +END + +(* Gives up on the goals under focus: the goals are considered solved, + but the proof cannot be closed until the user goes back and solve + these goals. *) +TACTIC EXTEND give_up +| [ "give_up" ] -> + [ Proofview.give_up ] +END + +(* cycles [n] goals *) +TACTIC EXTEND cycle +| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle n ] +END + +(* swaps goals number [i] and [j] *) +TACTIC EXTEND swap +| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap i j ] +END + +(* reverses the list of focused goals *) +TACTIC EXTEND revgoals +| [ "revgoals" ] -> [ Proofview.revgoals ] +END + +type cmp = + | Eq + | Lt | Le + | Gt | Ge + +type 'i test = + | Test of cmp * 'i * 'i + +let pr_cmp = function + | Eq -> Pp.str"=" + | Lt -> Pp.str"<" + | Le -> Pp.str"<=" + | Gt -> Pp.str">" + | Ge -> Pp.str">=" + +let pr_cmp' _prc _prlc _prt = pr_cmp + +let pr_test_gen f (Test(c,x,y)) = + Pp.(f x ++ pr_cmp c ++ f y) + +let pr_test = pr_test_gen (Pputils.pr_or_var Pp.int) + +let pr_test' _prc _prlc _prt = pr_test + +let pr_itest = pr_test_gen Pp.int + +let pr_itest' _prc _prlc _prt = pr_itest + + + +ARGUMENT EXTEND comparison PRINTED BY pr_cmp' +| [ "=" ] -> [ Eq ] +| [ "<" ] -> [ Lt ] +| [ "<=" ] -> [ Le ] +| [ ">" ] -> [ Gt ] +| [ ">=" ] -> [ Ge ] + END + +let interp_test ist gls = function + | Test (c,x,y) -> + project gls , + Test(c,Tacinterp.interp_int_or_var ist x,Tacinterp.interp_int_or_var ist y) + +ARGUMENT EXTEND test + PRINTED BY pr_itest' + INTERPRETED BY interp_test + RAW_PRINTED BY pr_test' + GLOB_PRINTED BY pr_test' +| [ int_or_var(x) comparison(c) int_or_var(y) ] -> [ Test(c,x,y) ] +END + +let interp_cmp = function + | Eq -> Int.equal + | Lt -> ((<):int->int->bool) + | Le -> ((<=):int->int->bool) + | Gt -> ((>):int->int->bool) + | Ge -> ((>=):int->int->bool) + +let run_test = function + | Test(c,x,y) -> interp_cmp c x y + +let guard tst = + if run_test tst then + Proofview.tclUNIT () + else + let msg = Pp.(str"Condition not satisfied:"++ws 1++(pr_itest tst)) in + Tacticals.New.tclZEROMSG msg + + +TACTIC EXTEND guard +| [ "guard" test(tst) ] -> [ guard tst ] +END + +let decompose l c = + Proofview.Goal.enter { enter = begin fun gl -> + let to_ind c = + if isInd c then Univ.out_punivs (destInd c) + else error "not an inductive type" + in + let l = List.map to_ind l in + Elim.h_decompose l c + end } + +TACTIC EXTEND decompose +| [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ] +END + +(** library/keys *) + +VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF +| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> [ + let it c = snd (Constrintern.interp_open_constr (Global.env ()) Evd.empty c) in + let k1 = Keys.constr_key (it c) in + let k2 = Keys.constr_key (it c') in + match k1, k2 with + | Some k1, Some k2 -> Keys.declare_equiv_keys k1 k2 + | _ -> () ] +END + +VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY +| [ "Print" "Equivalent" "Keys" ] -> [ Feedback.msg_info (Keys.pr_keys Printer.pr_global) ] +END + + +VERNAC COMMAND EXTEND OptimizeProof +| [ "Optimize" "Proof" ] => [ Vernac_classifier.classify_as_proofstep ] -> + [ Proof_global.compact_the_proof () ] +| [ "Optimize" "Heap" ] => [ Vernac_classifier.classify_as_proofstep ] -> + [ Gc.compact () ] +END diff --git a/plugins/ltac/extratactics.mli b/plugins/ltac/extratactics.mli new file mode 100644 index 000000000..18334dafe --- /dev/null +++ b/plugins/ltac/extratactics.mli @@ -0,0 +1,14 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit Proofview.tactic +val injHyp : Names.Id.t -> unit Proofview.tactic + +(* val refine_tac : Evd.open_constr -> unit Proofview.tactic *) + +val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Tacexpr.delayed_open option -> unit Proofview.tactic diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4 new file mode 100644 index 000000000..a37cf306e --- /dev/null +++ b/plugins/ltac/g_auto.ml4 @@ -0,0 +1,228 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ Eauto.e_assumption ] +END + +TACTIC EXTEND eexact +| [ "eexact" constr(c) ] -> [ Eauto.e_give_exact c ] +END + +let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases + +ARGUMENT EXTEND hintbases + TYPED AS preident_list_opt + PRINTED BY pr_hintbases +| [ "with" "*" ] -> [ None ] +| [ "with" ne_preident_list(l) ] -> [ Some l ] +| [ ] -> [ Some [] ] +END + +let eval_uconstrs ist cs = + let flags = { + Pretyping.use_typeclasses = false; + solve_unification_constraints = true; + use_hook = Some Pfedit.solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true + } in + List.map (fun c -> Pretyping.type_uconstr ~flags ist c) cs + +let pr_auto_using_raw _ _ _ = Pptactic.pr_auto_using Ppconstr.pr_constr_expr +let pr_auto_using_glob _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> Printer.pr_glob_constr c) +let pr_auto_using _ _ _ = Pptactic.pr_auto_using Printer.pr_closed_glob + +ARGUMENT EXTEND auto_using + TYPED AS uconstr_list + PRINTED BY pr_auto_using + RAW_TYPED AS uconstr_list + RAW_PRINTED BY pr_auto_using_raw + GLOB_TYPED AS uconstr_list + GLOB_PRINTED BY pr_auto_using_glob +| [ "using" ne_uconstr_list_sep(l, ",") ] -> [ l ] +| [ ] -> [ [] ] +END + +(** Auto *) + +TACTIC EXTEND trivial +| [ "trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND info_trivial +| [ "info_trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND debug_trivial +| [ "debug" "trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND auto +| [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto n (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND info_auto +| [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND debug_auto +| [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db ] +END + +(** Eauto *) + +TACTIC EXTEND prolog +| [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] -> + [ Eauto.prolog_tac (eval_uconstrs ist l) n ] +END + +let make_depth n = snd (Eauto.make_dimension n None) + +TACTIC EXTEND eauto +| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND new_eauto +| [ "new" "auto" int_or_var_opt(n) auto_using(lems) + hintbases(db) ] -> + [ match db with + | None -> Auto.new_full_auto (make_depth n) (eval_uconstrs ist lems) + | Some l -> Auto.new_auto (make_depth n) (eval_uconstrs ist lems) l ] +END + +TACTIC EXTEND debug_eauto +| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND info_eauto +| [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND dfs_eauto +| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND autounfold +| [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> [ Eauto.autounfold_tac db cl ] +END + +TACTIC EXTEND autounfold_one +| [ "autounfold_one" hintbases(db) "in" hyp(id) ] -> + [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, Locus.InHyp)) ] +| [ "autounfold_one" hintbases(db) ] -> + [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ] + END + +TACTIC EXTEND autounfoldify +| [ "autounfoldify" constr(x) ] -> [ + let db = match Term.kind_of_term x with + | Term.Const (c,_) -> Names.Label.to_string (Names.con_label c) + | _ -> assert false + in Eauto.autounfold ["core";db] Locusops.onConcl + ] +END + +TACTIC EXTEND unify +| ["unify" constr(x) constr(y) ] -> [ Tactics.unify x y ] +| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ + let table = try Some (Hints.searchtable_map base) with Not_found -> None in + match table with + | None -> + let msg = str "Hint table " ++ str base ++ str " not found" in + Tacticals.New.tclZEROMSG msg + | Some t -> + let state = Hints.Hint_db.transparent_state t in + Tactics.unify ~state x y + ] +END + + +TACTIC EXTEND convert_concl_no_check +| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x Term.DEFAULTcast ] +END + +let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_reference +let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global +let glob_hints_path_atom ist = Hints.glob_hints_path_atom + +ARGUMENT EXTEND hints_path_atom + PRINTED BY pr_hints_path_atom + + GLOBALIZED BY glob_hints_path_atom + + RAW_PRINTED BY pr_pre_hints_path_atom + GLOB_PRINTED BY pr_hints_path_atom +| [ ne_global_list(g) ] -> [ Hints.PathHints g ] +| [ "_" ] -> [ Hints.PathAny ] +END + +let pr_hints_path prc prx pry c = Hints.pp_hints_path c +let pr_pre_hints_path prc prx pry c = Hints.pp_hints_path_gen Libnames.pr_reference c +let glob_hints_path ist = Hints.glob_hints_path + +ARGUMENT EXTEND hints_path +PRINTED BY pr_hints_path + +GLOBALIZED BY glob_hints_path +RAW_PRINTED BY pr_pre_hints_path +GLOB_PRINTED BY pr_hints_path + +| [ "(" hints_path(p) ")" ] -> [ p ] +| [ hints_path(p) "*" ] -> [ Hints.PathStar p ] +| [ "emp" ] -> [ Hints.PathEmpty ] +| [ "eps" ] -> [ Hints.PathEpsilon ] +| [ hints_path(p) "|" hints_path(q) ] -> [ Hints.PathOr (p, q) ] +| [ hints_path_atom(a) ] -> [ Hints.PathAtom a ] +| [ hints_path(p) hints_path(q) ] -> [ Hints.PathSeq (p, q) ] +END + +ARGUMENT EXTEND opthints + TYPED AS preident_list_opt + PRINTED BY pr_hintbases +| [ ":" ne_preident_list(l) ] -> [ Some l ] +| [ ] -> [ None ] +END + +VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF +| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ + let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in + Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ())) + (match dbnames with None -> ["core"] | Some l -> l) entry ] +END + diff --git a/plugins/ltac/g_class.ml4 b/plugins/ltac/g_class.ml4 new file mode 100644 index 000000000..a28132a4b --- /dev/null +++ b/plugins/ltac/g_class.ml4 @@ -0,0 +1,120 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + let gr = Smartlocate.global_with_alias r in + let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in + Classes.set_typeclass_transparency ev false b) cl + +VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings CLASSIFIED AS SIDEFF +| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ + set_transparency cl true ] +END + +VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings CLASSIFIED AS SIDEFF +| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [ + set_transparency cl false ] +END + +open Genarg + +let pr_debug _prc _prlc _prt b = + if b then Pp.str "debug" else Pp.mt() + +ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug +| [ "debug" ] -> [ true ] +| [ ] -> [ false ] +END + +let pr_search_strategy _prc _prlc _prt = function + | Some Dfs -> Pp.str "dfs" + | Some Bfs -> Pp.str "bfs" + | None -> Pp.mt () + +ARGUMENT EXTEND eauto_search_strategy PRINTED BY pr_search_strategy +| [ "(bfs)" ] -> [ Some Bfs ] +| [ "(dfs)" ] -> [ Some Dfs ] +| [ ] -> [ None ] +END + +(* true = All transparent, false = Opaque if possible *) + +VERNAC COMMAND EXTEND Typeclasses_Settings CLASSIFIED AS SIDEFF + | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) int_opt(depth) ] -> [ + set_typeclasses_debug d; + Option.iter set_typeclasses_strategy s; + set_typeclasses_depth depth + ] +END + +(** Compatibility: typeclasses eauto has 8.5 and 8.6 modes *) +TACTIC EXTEND typeclasses_eauto + | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) "with" ne_preident_list(l) ] -> + [ typeclasses_eauto ~strategy:Bfs ~depth:d l ] + | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] -> + [ typeclasses_eauto ~depth:d l ] + | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> [ + typeclasses_eauto ~only_classes:true ~depth:d [Hints.typeclasses_db] ] +END + +TACTIC EXTEND head_of_constr + [ "head_of_constr" ident(h) constr(c) ] -> [ head_of_constr h c ] +END + +TACTIC EXTEND not_evar + [ "not_evar" constr(ty) ] -> [ not_evar ty ] +END + +TACTIC EXTEND is_ground + [ "is_ground" constr(ty) ] -> [ Proofview.V82.tactic (is_ground ty) ] +END + +TACTIC EXTEND autoapply + [ "autoapply" constr(c) "using" preident(i) ] -> [ Proofview.V82.tactic (autoapply c i) ] +END + +(** TODO: DEPRECATE *) +(* A progress test that allows to see if the evars have changed *) +open Term +open Proofview.Goal +open Proofview.Notations + +let rec eq_constr_mod_evars x y = + match kind_of_term x, kind_of_term y with + | Evar (e1, l1), Evar (e2, l2) when not (Evar.equal e1 e2) -> true + | _, _ -> compare_constr eq_constr_mod_evars x y + +let progress_evars t = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let check = + Proofview.Goal.nf_enter { enter = begin fun gl' -> + let newconcl = Proofview.Goal.concl gl' in + if eq_constr_mod_evars concl newconcl + then Tacticals.New.tclFAIL 0 (Pp.str"No progress made (modulo evars)") + else Proofview.tclUNIT () + end } + in t <*> check + end } + +TACTIC EXTEND progress_evars + [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.tactic_of_value ist t) ] +END diff --git a/plugins/ltac/g_eqdecide.ml4 b/plugins/ltac/g_eqdecide.ml4 new file mode 100644 index 000000000..905653281 --- /dev/null +++ b/plugins/ltac/g_eqdecide.ml4 @@ -0,0 +1,27 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ decideEqualityGoal ] +END + +TACTIC EXTEND compare +| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ] +END diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 new file mode 100644 index 000000000..54229bb2a --- /dev/null +++ b/plugins/ltac/g_ltac.ml4 @@ -0,0 +1,526 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* a + | e -> Tacexp (e:raw_tactic_expr) + +let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () +let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n +let genarg_of_ipattern pat = in_gen (rawwit Stdarg.wit_intro_pattern) pat +let genarg_of_uconstr c = in_gen (rawwit Stdarg.wit_uconstr) c +let in_tac tac = in_gen (rawwit Tacarg.wit_ltac) tac + +let reference_to_id = function + | Libnames.Ident (loc, id) -> (loc, id) + | Libnames.Qualid (loc,_) -> + CErrors.user_err ~loc + (str "This expression should be a simple identifier.") + +let tactic_mode = Gram.entry_create "vernac:tactic_command" + +let new_entry name = + let e = Gram.entry_create name in + e + +let toplevel_selector = new_entry "vernac:toplevel_selector" +let tacdef_body = new_entry "tactic:tacdef_body" + +(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for + proof editing and changes nothing else). Then sets it as the default proof mode. *) +let _ = + let mode = { + Proof_global.name = "Classic"; + set = (fun () -> set_command_entry tactic_mode); + reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); + } in + Proof_global.register_proof_mode mode + +(* Hack to parse "[ id" without dropping [ *) +let test_bracket_ident = + Gram.Entry.of_parser "test_bracket_ident" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD "[" -> + (match get_tok (stream_nth 1 strm) with + | IDENT _ -> () + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + +(* Tactics grammar rules *) + +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 + operconstr; + + tactic_then_last: + [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> + Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) + | -> [||] + ] ] + ; + tactic_then_gen: + [ [ ta = tactic_expr; "|"; (first,last) = tactic_then_gen -> (ta::first, last) + | ta = tactic_expr; ".."; l = tactic_then_last -> ([], Some (ta, l)) + | ".."; l = tactic_then_last -> ([], Some (TacId [], l)) + | ta = tactic_expr -> ([ta], None) + | "|"; (first,last) = tactic_then_gen -> (TacId [] :: first, last) + | -> ([TacId []], None) + ] ] + ; + tactic_then_locality: (* [true] for the local variant [TacThens] and [false] + for [TacExtend] *) + [ [ "[" ; l = OPT">" -> if Option.is_empty l then true else false ] ] + ; + tactic_expr: + [ "5" RIGHTA + [ te = binder_tactic -> te ] + | "4" LEFTA + [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, ta1) + | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0,ta1) + | ta0 = tactic_expr; ";"; l = tactic_then_locality; (first,tail) = tactic_then_gen; "]" -> + match l , tail with + | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) + | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) + | false , None -> TacThen (ta0,TacDispatch first) + | true , None -> TacThens (ta0,first) ] + | "3" RIGHTA + [ IDENT "try"; ta = tactic_expr -> TacTry ta + | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta) + | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> TacTimeout (n,ta) + | IDENT "time"; s = OPT string; ta = tactic_expr -> TacTime (s,ta) + | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta + | IDENT "progress"; ta = tactic_expr -> TacProgress ta + | IDENT "once"; ta = tactic_expr -> TacOnce ta + | IDENT "exactly_once"; ta = tactic_expr -> TacExactlyOnce ta + | IDENT "infoH"; ta = tactic_expr -> TacShowHyps ta +(*To do: put Abstract in Refiner*) + | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) + | IDENT "abstract"; tc = NEXT; "using"; s = ident -> + TacAbstract (tc,Some s) + | sel = selector; ta = tactic_expr -> TacSelect (sel, ta) ] +(*End of To do*) + | "2" RIGHTA + [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> TacOr (ta0,ta1) + | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> TacOr (ta0,ta1) + | IDENT "tryif" ; ta = tactic_expr ; + "then" ; tat = tactic_expr ; + "else" ; tae = tactic_expr -> TacIfThenCatch(ta,tat,tae) + | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1) + | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ] + | "1" RIGHTA + [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> + TacMatchGoal (b,false,mrl) + | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; + mrl = match_context_list; "end" -> + TacMatchGoal (b,true,mrl) + | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> + TacMatch (b,c,mrl) + | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + TacFirst l + | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + TacSolve l + | IDENT "idtac"; l = LIST0 message_token -> TacId l + | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; + l = LIST0 message_token -> TacFail (g,n,l) + | st = simple_tactic -> st + | a = tactic_arg -> TacArg(!@loc,a) + | r = reference; la = LIST0 tactic_arg_compat -> + TacArg(!@loc,TacCall (!@loc,r,la)) ] + | "0" + [ "("; a = tactic_expr; ")" -> a + | "["; ">"; (tf,tail) = tactic_then_gen; "]" -> + begin match tail with + | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) + | None -> TacDispatch tf + end + | a = tactic_atom -> TacArg (!@loc,a) ] ] + ; + failkw: + [ [ IDENT "fail" -> TacLocal | IDENT "gfail" -> TacGlobal ] ] + ; + (* binder_tactic: level 5 of tactic_expr *) + binder_tactic: + [ RIGHTA + [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> + TacFun (it,body) + | "let"; isrec = [IDENT "rec" -> true | -> false]; + llc = LIST1 let_clause SEP "with"; "in"; + body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body) + | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] + ; + (* Tactic arguments to the right of an application *) + tactic_arg_compat: + [ [ a = tactic_arg -> a + | c = Constr.constr -> (match c with CRef (r,None) -> Reference r | c -> ConstrMayEval (ConstrTerm c)) + (* Unambiguous entries: tolerated w/o "ltac:" modifier *) + | "()" -> TacGeneric (genarg_of_unit ()) ] ] + ; + (* Can be used as argument and at toplevel in tactic expressions. *) + tactic_arg: + [ [ c = constr_eval -> ConstrMayEval c + | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l + | IDENT "type_term"; c=uconstr -> TacPretype c + | IDENT "numgoals" -> TacNumgoals ] ] + ; + (* If a qualid is given, use its short name. TODO: have the shortest + non ambiguous name where dots are replaced by "_"? Probably too + verbose most of the time. *) + fresh_id: + [ [ s = STRING -> ArgArg s (*| id = ident -> ArgVar (!@loc,id)*) + | qid = qualid -> let (_pth,id) = Libnames.repr_qualid (snd qid) in ArgVar (!@loc,id) ] ] + ; + constr_eval: + [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> + ConstrEval (rtc,c) + | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> + ConstrContext (id,c) + | IDENT "type"; IDENT "of"; c = Constr.constr -> + ConstrTypeOf c ] ] + ; + constr_may_eval: (* For extensions *) + [ [ c = constr_eval -> c + | c = Constr.constr -> ConstrTerm c ] ] + ; + tactic_atom: + [ [ n = integer -> TacGeneric (genarg_of_int n) + | r = reference -> TacCall (!@loc,r,[]) + | "()" -> TacGeneric (genarg_of_unit ()) ] ] + ; + match_key: + [ [ "match" -> Once + | "lazymatch" -> Select + | "multimatch" -> General ] ] + ; + input_fun: + [ [ "_" -> None + | l = ident -> Some l ] ] + ; + let_clause: + [ [ id = identref; ":="; te = tactic_expr -> + (id, arg_of_expr te) + | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> + (id, arg_of_expr (TacFun(args,te))) ] ] + ; + 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) + | pc = Constr.lconstr_pattern -> Term pc ] ] + ; + match_hyps: + [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) + | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt) + | na = name; ":="; mpv = match_pattern -> + let t, ty = + match mpv with + | Term t -> (match t with + | CCast (loc, t, (CastConv ty | CastVM ty | CastNative ty)) -> Term t, Some (Term ty) + | _ -> mpv, None) + | _ -> mpv, None + in Def (na, t, Option.default (Term (CHole (Loc.ghost, None, IntroAnonymous, None))) ty) + ] ] + ; + match_context_rule: + [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; + "=>"; te = tactic_expr -> Pat (largs, mp, te) + | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; + "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te) + | "_"; "=>"; te = tactic_expr -> All te ] ] + ; + match_context_list: + [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl + | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ] + ; + match_rule: + [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te) + | "_"; "=>"; te = tactic_expr -> All te ] ] + ; + match_list: + [ [ mrl = LIST1 match_rule SEP "|" -> mrl + | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] + ; + message_token: + [ [ id = identref -> MsgIdent id + | s = STRING -> MsgString s + | n = integer -> MsgInt n ] ] + ; + + ltac_def_kind: + [ [ ":=" -> false + | "::=" -> true ] ] + ; + + (* Definitions for tactics *) + tacdef_body: + [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> + if redef then Tacexpr.TacticRedefinition (name, TacFun (it, body)) + else + let id = reference_to_id name in + Tacexpr.TacticDefinition (id, TacFun (it, body)) + | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> + if redef then Tacexpr.TacticRedefinition (name, body) + else + let id = reference_to_id name in + Tacexpr.TacticDefinition (id, body) + ] ] + ; + tactic: + [ [ tac = tactic_expr -> tac ] ] + ; + + range_selector: + [ [ n = natural ; "-" ; m = natural -> (n, m) + | n = natural -> (n, n) ] ] + ; + (* We unfold a range selectors list once so that we can make a special case + * for a unique SelectNth selector. *) + range_selector_or_nth: + [ [ n = natural ; "-" ; m = natural; + l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> + SelectList ((n, m) :: Option.default [] l) + | n = natural; + l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> + Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l ] ] + ; + selector_body: + [ [ l = range_selector_or_nth -> l + | test_bracket_ident; "["; id = ident; "]" -> SelectId id ] ] + ; + selector: + [ [ IDENT "only"; sel = selector_body; ":" -> sel ] ] + ; + toplevel_selector: + [ [ sel = selector_body; ":" -> sel + | IDENT "all"; ":" -> SelectAll ] ] + ; + tactic_mode: + [ [ g = OPT toplevel_selector; tac = G_vernac.subgoal_command -> tac g ] ] + ; + command: + [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; + l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] -> + Vernacexpr.VernacProof (Some (in_tac ta), G_proofs.hint_proof_using G_vernac.section_subset_expr l) + | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; + ta = OPT [ "with"; ta = Pltac.tactic -> in_tac ta ] -> + Vernacexpr.VernacProof (ta,Some l) ] ] + ; + hint: + [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; + tac = Pltac.tactic -> + Vernacexpr.HintsExtern (n,c, in_tac tac) ] ] + ; + operconstr: LEVEL "0" + [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> + let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in + CHole (!@loc, None, IntroAnonymous, Some arg) ] ] + ; + END + +open Stdarg +open Tacarg +open Vernacexpr +open Vernac_classifier +open Goptions +open Libnames + +let print_info_trace = ref None + +let _ = declare_int_option { + optsync = true; + optdepr = false; + optname = "print info trace"; + optkey = ["Info" ; "Level"]; + optread = (fun () -> !print_info_trace); + optwrite = fun n -> print_info_trace := n; +} + +let vernac_solve n info tcom b = + let status = Proof_global.with_current_proof (fun etac p -> + let with_end_tac = if b then Some etac else None in + let global = match n with SelectAll | SelectList _ -> true | _ -> false in + let info = Option.append info !print_info_trace in + let (p,status) = + Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p + in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p,status) in + if not status then Feedback.feedback Feedback.AddedAxiom + +let pr_range_selector (i, j) = + if Int.equal i j then int i + else int i ++ str "-" ++ int j + +let pr_ltac_selector = function +| SelectNth i -> int i ++ str ":" +| SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ + str "]" ++ str ":" +| SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" +| SelectAll -> str "all" ++ str ":" + +VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector +| [ toplevel_selector(s) ] -> [ s ] +END + +let pr_ltac_info n = str "Info" ++ spc () ++ int n + +VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info +| [ "Info" natural(n) ] -> [ n ] +END + +let pr_ltac_use_default b = + if b then (* Bug: a space is inserted before "..." *) str ".." else mt () + +VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default +| [ "." ] -> [ false ] +| [ "..." ] -> [ true ] +END + +let is_anonymous_abstract = function + | TacAbstract (_,None) -> true + | TacSolve [TacAbstract (_,None)] -> true + | _ -> false +let rm_abstract = function + | TacAbstract (t,_) -> t + | TacSolve [TacAbstract (t,_)] -> TacSolve [t] + | x -> x +let is_explicit_terminator = function TacSolve _ -> true | _ -> false + +VERNAC tactic_mode EXTEND VernacSolve +| [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + [ classify_as_proofstep ] -> [ + let g = Option.default (Proof_global.get_default_goal_selector ()) g in + vernac_solve g n t def + ] +| [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + [ + let anon_abstracting_tac = is_anonymous_abstract t in + let solving_tac = is_explicit_terminator t in + let parallel = `Yes (solving_tac,anon_abstracting_tac) in + let pbr = if solving_tac then Some "par" else None in + VtProofStep{ parallel = parallel; proof_block_detection = pbr }, + VtLater + ] -> [ + let t = rm_abstract t in + vernac_solve SelectAll n t def + ] +END + +let pr_ltac_tactic_level n = str "(at level " ++ int n ++ str ")" + +VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY pr_ltac_tactic_level +| [ "(" "at" "level" natural(n) ")" ] -> [ n ] +END + +VERNAC ARGUMENT EXTEND ltac_production_sep +| [ "," string(sep) ] -> [ sep ] +END + +let pr_ltac_production_item = function +| Tacentries.TacTerm s -> quote (str s) +| Tacentries.TacNonTerm (_, (arg, sep), id) -> + let sep = match sep with + | None -> mt () + | Some sep -> str "," ++ spc () ++ quote (str sep) + in + str arg ++ str "(" ++ Nameops.pr_id id ++ sep ++ str ")" + +VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item +| [ string(s) ] -> [ Tacentries.TacTerm s ] +| [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> + [ Tacentries.TacNonTerm (loc, (Names.Id.to_string nt, sep), p) ] +END + +VERNAC COMMAND EXTEND VernacTacticNotation +| [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => + [ VtUnknown, VtNow ] -> + [ + let l = Locality.LocalityFixme.consume () in + let n = Option.default 0 n in + Tacentries.add_tactic_notation (Locality.make_module_locality l) n r e + ] +END + +VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY +| [ "Print" "Ltac" reference(r) ] -> + [ Feedback.msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ] +END + +let pr_ltac_ref = Libnames.pr_reference + +let pr_tacdef_body tacdef_body = + let id, redef, body = + match tacdef_body with + | TacticDefinition ((_,id), body) -> Nameops.pr_id id, false, body + | TacticRedefinition (id, body) -> pr_ltac_ref id, true, body + in + let idl, body = + match body with + | Tacexpr.TacFun (idl,b) -> idl,b + | _ -> [], body in + id ++ + prlist (function None -> str " _" + | Some id -> spc () ++ Nameops.pr_id id) idl + ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) + ++ Pptactic.pr_raw_tactic body + +VERNAC ARGUMENT EXTEND ltac_tacdef_body +PRINTED BY pr_tacdef_body +| [ tacdef_body(t) ] -> [ t ] +END + +VERNAC COMMAND EXTEND VernacDeclareTacticDefinition +| [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => [ + VtSideff (List.map (function + | TacticDefinition ((_,r),_) -> r + | TacticRedefinition (Ident (_,r),_) -> r + | TacticRedefinition (Qualid (_,q),_) -> snd(repr_qualid q)) l), VtLater + ] -> [ + let lc = Locality.LocalityFixme.consume () in + Tacentries.register_ltac (Locality.make_module_locality lc) l + ] +END + +VERNAC COMMAND EXTEND VernacPrintLtacs CLASSIFIED AS QUERY +| [ "Print" "Ltac" "Signatures" ] -> [ Tacentries.print_ltacs () ] +END diff --git a/plugins/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.ml4 new file mode 100644 index 000000000..d286a5870 --- /dev/null +++ b/plugins/ltac/g_obligations.ml4 @@ -0,0 +1,161 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + snd (get_default_tactic ()) + end in + Obligations.default_tactic := tac + +let with_tac f tac = + let env = { Genintern.genv = Global.env (); ltacvars = Names.Id.Set.empty } in + let tac = match tac with + | None -> None + | Some tac -> + let tac = Genarg.in_gen (Genarg.rawwit wit_ltac) tac in + let _, tac = Genintern.generic_intern env tac in + Some tac + in + f tac + +(* We define new entries for programs, with the use of this module + * Subtac. These entries are named Subtac. + *) + +module Gram = Pcoq.Gram +module Tactic = Pltac + +open Pcoq + +let sigref = mkRefC (Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Init.Specif.sig")) + +type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type + +let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = + Genarg.create_arg "withtac" + +let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac) + +GEXTEND Gram + GLOBAL: withtac; + + withtac: + [ [ "with"; t = Tactic.tactic -> Some t + | -> None ] ] + ; + + Constr.closed_binder: + [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> + let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in + [LocalRawAssum ([id], default_binder_kind, typ)] + ] ]; + + END + +open Obligations + +let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac +let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac + +let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) + +VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl +| [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> + [ obligation (num, Some name, Some t) tac ] +| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> + [ obligation (num, Some name, None) tac ] +| [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> + [ obligation (num, None, Some t) tac ] +| [ "Obligation" integer(num) withtac(tac) ] -> + [ obligation (num, None, None) tac ] +| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> + [ next_obligation (Some name) tac ] +| [ "Next" "Obligation" withtac(tac) ] -> [ next_obligation None tac ] +END + +VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF +| [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] -> + [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligation" integer(num) "with" tactic(t) ] -> + [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] +END + +VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF +| [ "Solve" "Obligations" "of" ident(name) "with" tactic(t) ] -> + [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligations" "with" tactic(t) ] -> + [ try_solve_obligations None (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligations" ] -> + [ try_solve_obligations None None ] +END + +VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF +| [ "Solve" "All" "Obligations" "with" tactic(t) ] -> + [ solve_all_obligations (Some (Tacinterp.interp t)) ] +| [ "Solve" "All" "Obligations" ] -> + [ solve_all_obligations None ] +END + +VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF +| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] +| [ "Admit" "Obligations" ] -> [ admit_obligations None ] +END + +VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF +| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ + set_default_tactic + (Locality.make_section_locality (Locality.LocalityFixme.consume ())) + (Tacintern.glob_tactic t) ] +END + +open Pp + +VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY +| [ "Show" "Obligation" "Tactic" ] -> [ + Feedback.msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ] +END + +VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY +| [ "Obligations" "of" ident(name) ] -> [ show_obligations (Some name) ] +| [ "Obligations" ] -> [ show_obligations None ] +END + +VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY +| [ "Preterm" "of" ident(name) ] -> [ Feedback.msg_info (show_term (Some name)) ] +| [ "Preterm" ] -> [ Feedback.msg_info (show_term None) ] +END + +open Pp + +(* Declare a printer for the content of Program tactics *) +let () = + let printer _ _ _ = function + | None -> mt () + | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac + in + (* should not happen *) + let dummy _ _ _ expr = assert false in + Pptactic.declare_extra_genarg_pprule wit_withtac printer dummy dummy diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 new file mode 100644 index 000000000..b1c4f58eb --- /dev/null +++ b/plugins/ltac/g_rewrite.ml4 @@ -0,0 +1,274 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ bl ] +END + +type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast +type glob_strategy = (Tacexpr.glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast + +let interp_strategy ist gl s = + let sigma = project gl in + sigma, strategy_of_ast s +let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s +let subst_strategy s str = str + +let pr_strategy _ _ _ (s : strategy) = Pp.str "" +let pr_raw_strategy prc prlc _ (s : raw_strategy) = + let prr = Pptactic.pr_red_expr (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_reference, prc) in + Rewrite.pr_strategy prc prr s +let pr_glob_strategy prc prlc _ (s : glob_strategy) = + let prr = Pptactic.pr_red_expr + (Ppconstr.pr_constr_expr, + Ppconstr.pr_lconstr_expr, + Pputils.pr_or_by_notation Libnames.pr_reference, + Ppconstr.pr_constr_expr) + in + Rewrite.pr_strategy prc prr s + +ARGUMENT EXTEND rewstrategy + PRINTED BY pr_strategy + + INTERPRETED BY interp_strategy + GLOBALIZED BY glob_strategy + SUBSTITUTED BY subst_strategy + + RAW_PRINTED BY pr_raw_strategy + GLOB_PRINTED BY pr_glob_strategy + + [ glob(c) ] -> [ StratConstr (c, true) ] + | [ "<-" constr(c) ] -> [ StratConstr (c, false) ] + | [ "subterms" rewstrategy(h) ] -> [ StratUnary (Subterms, h) ] + | [ "subterm" rewstrategy(h) ] -> [ StratUnary (Subterm, h) ] + | [ "innermost" rewstrategy(h) ] -> [ StratUnary(Innermost, h) ] + | [ "outermost" rewstrategy(h) ] -> [ StratUnary(Outermost, h) ] + | [ "bottomup" rewstrategy(h) ] -> [ StratUnary(Bottomup, h) ] + | [ "topdown" rewstrategy(h) ] -> [ StratUnary(Topdown, h) ] + | [ "id" ] -> [ StratId ] + | [ "fail" ] -> [ StratFail ] + | [ "refl" ] -> [ StratRefl ] + | [ "progress" rewstrategy(h) ] -> [ StratUnary (Progress, h) ] + | [ "try" rewstrategy(h) ] -> [ StratUnary (Try, h) ] + | [ "any" rewstrategy(h) ] -> [ StratUnary (Any, h) ] + | [ "repeat" rewstrategy(h) ] -> [ StratUnary (Repeat, h) ] + | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary (Compose, h, h') ] + | [ "(" rewstrategy(h) ")" ] -> [ h ] + | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary (Choice, h, h') ] + | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ] + | [ "hints" preident(h) ] -> [ StratHints (false, h) ] + | [ "terms" constr_list(h) ] -> [ StratTerms h ] + | [ "eval" red_expr(r) ] -> [ StratEval r ] + | [ "fold" constr(c) ] -> [ StratFold c ] +END + +(* By default the strategy for "rewrite_db" is top-down *) + +let db_strat db = StratUnary (Topdown, StratHints (false, db)) +let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db)) + +TACTIC EXTEND rewrite_strat +| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ] +| [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ] +| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ cl_rewrite_clause_db db (Some id) ] +| [ "rewrite_db" preident(db) ] -> [ cl_rewrite_clause_db db None ] +END + +let clsubstitute o c = + let is_tac id = match fst (fst (snd c)) with GVar (_, id') when Id.equal id' id -> true | _ -> false in + Tacticals.onAllHypsAndConcl + (fun cl -> + match cl with + | Some id when is_tac id -> tclIDTAC + | _ -> Proofview.V82.of_tactic (cl_rewrite_clause c o AllOccurrences cl)) + +TACTIC EXTEND substitute +| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ Proofview.V82.tactic (clsubstitute o c) ] +END + + +(* Compatibility with old Setoids *) + +TACTIC EXTEND setoid_rewrite + [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ] + -> [ cl_rewrite_clause c o AllOccurrences None ] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> + [ cl_rewrite_clause c o AllOccurrences (Some id) ] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> + [ cl_rewrite_clause c o (occurrences_of occ) None ] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> + [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] -> + [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] +END + +VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF + | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> + [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ] + + | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "as" ident(n) ] -> + [ declare_relation a aeq n (Some lemma1) None None ] + | [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> + [ declare_relation a aeq n None None None ] +END + +VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF + [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + "as" ident(n) ] -> + [ declare_relation a aeq n None (Some lemma2) None ] + | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ] +END + +VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF + [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ] + | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] + | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + [ declare_relation a aeq n None None (Some lemma3) ] +END + +type binders_argtype = local_binder list + +let wit_binders = + (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type) + +let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders) + +let () = + let raw_printer _ _ _ l = Pp.pr_non_empty_arg Ppconstr.pr_binders l in + let printer _ _ _ _ = Pp.str "" in + Pptactic.declare_extra_genarg_pprule wit_binders raw_printer printer printer + +open Pcoq + +GEXTEND Gram + GLOBAL: binders; + binders: + [ [ b = Pcoq.Constr.binders -> b ] ]; +END + +VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + "reflexivity" "proved" "by" constr(lemma1) + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n (Some lemma1) None None ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None None None ] +END + +VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF + [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None (Some lemma2) None ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ] +END + +VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF + [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] +END + +VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF + [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] a aeq t n ] + | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders a aeq t n ] + | [ "Add" "Morphism" constr(m) ":" ident(n) ] + (* This command may or may not open a goal *) + => [ Vernacexpr.VtUnknown, Vernacexpr.VtNow ] + -> [ add_morphism_infer (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) m n ] + | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] + => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] + -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] m s n ] + | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) + "with" "signature" lconstr(s) "as" ident(n) ] + => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] + -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders m s n ] +END + +TACTIC EXTEND setoid_symmetry + [ "setoid_symmetry" ] -> [ setoid_symmetry ] + | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ] +END + +TACTIC EXTEND setoid_reflexivity +[ "setoid_reflexivity" ] -> [ setoid_reflexivity ] +END + +TACTIC EXTEND setoid_transitivity + [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ] +| [ "setoid_etransitivity" ] -> [ setoid_transitivity None ] +END + +VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY + [ "Print" "Rewrite" "HintDb" preident(s) ] -> [ Feedback.msg_notice (Autorewrite.print_rewrite_hintdb s) ] +END diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4 new file mode 100644 index 000000000..685c07c9a --- /dev/null +++ b/plugins/ltac/g_tactic.ml4 @@ -0,0 +1,665 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* "; "<-" ; "by" ] +let _ = List.iter CLexer.add_keyword tactic_kw + +let err () = raise Stream.Failure + +(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) +(* admissible notation "(x t)" *) +let test_lpar_id_coloneq = + Gram.Entry.of_parser "lpar_id_coloneq" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD "(" -> + (match get_tok (stream_nth 1 strm) with + | IDENT _ -> + (match get_tok (stream_nth 2 strm) with + | KEYWORD ":=" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + +(* Hack to recognize "(x)" *) +let test_lpar_id_rpar = + Gram.Entry.of_parser "lpar_id_coloneq" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD "(" -> + (match get_tok (stream_nth 1 strm) with + | IDENT _ -> + (match get_tok (stream_nth 2 strm) with + | KEYWORD ")" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + +(* idem for (x:=t) and (1:=t) *) +let test_lpar_idnum_coloneq = + Gram.Entry.of_parser "test_lpar_idnum_coloneq" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD "(" -> + (match get_tok (stream_nth 1 strm) with + | IDENT _ | INT _ -> + (match get_tok (stream_nth 2 strm) with + | KEYWORD ":=" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + +(* idem for (x:t) *) +let test_lpar_id_colon = + Gram.Entry.of_parser "lpar_id_colon" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD "(" -> + (match get_tok (stream_nth 1 strm) with + | IDENT _ -> + (match get_tok (stream_nth 2 strm) with + | KEYWORD ":" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + +(* idem for (x1..xn:t) [n^2 complexity but exceptional use] *) +let check_for_coloneq = + Gram.Entry.of_parser "lpar_id_colon" + (fun strm -> + let rec skip_to_rpar p n = + match get_tok (List.last (Stream.npeek n strm)) with + | KEYWORD "(" -> skip_to_rpar (p+1) (n+1) + | KEYWORD ")" -> if Int.equal p 0 then n+1 else skip_to_rpar (p-1) (n+1) + | KEYWORD "." -> err () + | _ -> skip_to_rpar p (n+1) in + let rec skip_names n = + match get_tok (List.last (Stream.npeek n strm)) with + | IDENT _ | KEYWORD "_" -> skip_names (n+1) + | KEYWORD ":" -> skip_to_rpar 0 (n+1) (* skip a constr *) + | _ -> err () in + let rec skip_binders n = + match get_tok (List.last (Stream.npeek n strm)) with + | KEYWORD "(" -> skip_binders (skip_names (n+1)) + | IDENT _ | KEYWORD "_" -> skip_binders (n+1) + | KEYWORD ":=" -> () + | _ -> err () in + match get_tok (stream_nth 0 strm) with + | KEYWORD "(" -> skip_binders 2 + | _ -> err ()) + +let lookup_at_as_comma = + Gram.Entry.of_parser "lookup_at_as_comma" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD (","|"at"|"as") -> () + | _ -> err ()) + +open Constr +open Prim +open Pltac + +let mk_fix_tac (loc,id,bl,ann,ty) = + let n = + match bl,ann with + [([_],_,_)], None -> 1 + | _, Some x -> + let ids = List.map snd (List.flatten (List.map pi1 bl)) in + (try List.index Names.Name.equal (snd x) ids + with Not_found -> error "No such fix variable.") + | _ -> error "Cannot guess decreasing argument of fix." in + (id,n,CProdN(loc,bl,ty)) + +let mk_cofix_tac (loc,id,bl,ann,ty) = + let _ = Option.map (fun (aloc,_) -> + user_err ~loc:aloc + ~hdr:"Constr:mk_cofix_tac" + (Pp.str"Annotation forbidden in cofix expression.")) ann in + (id,CProdN(loc,bl,ty)) + +(* Functions overloaded by quotifier *) +let destruction_arg_of_constr (c,lbind as clbind) = match lbind with + | NoBindings -> + begin + try ElimOnIdent (Constrexpr_ops.constr_loc c,snd(Constrexpr_ops.coerce_to_id c)) + with e when CErrors.noncritical e -> ElimOnConstr clbind + end + | _ -> ElimOnConstr clbind + +let mkTacCase with_evar = function + | [(clear,ElimOnConstr cl),(None,None),None],None -> + TacCase (with_evar,(clear,cl)) + (* Reinterpret numbers as a notation for terms *) + | [(clear,ElimOnAnonHyp n),(None,None),None],None -> + TacCase (with_evar, + (clear,(CPrim (Loc.ghost, Numeral (Bigint.of_int n)), + NoBindings))) + (* Reinterpret ident as notations for variables in the context *) + (* because we don't know if they are quantified or not *) + | [(clear,ElimOnIdent id),(None,None),None],None -> + TacCase (with_evar,(clear,(CRef (Ident id,None),NoBindings))) + | ic -> + if List.exists (function ((_, ElimOnAnonHyp _),_,_) -> true | _ -> false) (fst ic) + then + error "Use of numbers as direct arguments of 'case' is not supported."; + TacInductionDestruct (false,with_evar,ic) + +let rec mkCLambdaN_simple_loc loc bll c = + match bll with + | ((loc1,_)::_ as idl,bk,t) :: bll -> + CLambdaN (loc,[idl,bk,t],mkCLambdaN_simple_loc (Loc.merge loc1 loc) bll c) + | ([],_,_) :: bll -> mkCLambdaN_simple_loc loc bll c + | [] -> c + +let mkCLambdaN_simple bl c = match bl with + | [] -> c + | h :: _ -> + let loc = Loc.merge (fst (List.hd (pi1 h))) (Constrexpr_ops.constr_loc c) in + mkCLambdaN_simple_loc loc bl c + +let loc_of_ne_list l = Loc.merge (fst (List.hd l)) (fst (List.last l)) + +let map_int_or_var f = function + | ArgArg x -> ArgArg (f x) + | ArgVar _ as y -> y + +let all_concl_occs_clause = { onhyps=Some[]; concl_occs=AllOccurrences } + +let merge_occurrences loc cl = function + | None -> + if Locusops.clause_with_generic_occurrences cl then (None, cl) + else + user_err ~loc (str "Found an \"at\" clause without \"with\" clause.") + | Some (occs, p) -> + let ans = match occs with + | AllOccurrences -> cl + | _ -> + begin match cl with + | { onhyps = Some []; concl_occs = AllOccurrences } -> + { onhyps = Some []; concl_occs = occs } + | { onhyps = Some [(AllOccurrences, id), l]; concl_occs = NoOccurrences } -> + { cl with onhyps = Some [(occs, id), l] } + | _ -> + if Locusops.clause_with_generic_occurrences cl then + user_err ~loc (str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.") + else + user_err ~loc (str "Cannot use clause \"at\" twice.") + end + in + (Some p, ans) + +let warn_deprecated_eqn_syntax = + CWarnings.create ~name:"deprecated-eqn-syntax" ~category:"deprecated" + (fun arg -> strbrk (Printf.sprintf "Syntax \"_eqn:%s\" is deprecated. Please use \"eqn:%s\" instead." arg arg)) + +(* Auxiliary grammar rules *) + +open Vernac_ + +GEXTEND Gram + GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis + bindings red_expr int_or_var open_constr uconstr + simple_intropattern in_clause clause_dft_concl hypident destruction_arg; + + int_or_var: + [ [ n = integer -> ArgArg n + | id = identref -> ArgVar id ] ] + ; + nat_or_var: + [ [ n = natural -> ArgArg n + | id = identref -> ArgVar id ] ] + ; + (* An identifier or a quotation meta-variable *) + id_or_meta: + [ [ id = identref -> id ] ] + ; + open_constr: + [ [ c = constr -> c ] ] + ; + uconstr: + [ [ c = constr -> c ] ] + ; + destruction_arg: + [ [ n = natural -> (None,ElimOnAnonHyp n) + | test_lpar_id_rpar; c = constr_with_bindings -> + (Some false,destruction_arg_of_constr c) + | c = constr_with_bindings_arg -> on_snd destruction_arg_of_constr c + ] ] + ; + constr_with_bindings_arg: + [ [ ">"; c = constr_with_bindings -> (Some true,c) + | c = constr_with_bindings -> (None,c) ] ] + ; + quantified_hypothesis: + [ [ id = ident -> NamedHyp id + | n = natural -> AnonHyp n ] ] + ; + conversion: + [ [ c = constr -> (None, c) + | c1 = constr; "with"; c2 = constr -> (Some (AllOccurrences,c1),c2) + | c1 = constr; "at"; occs = occs_nums; "with"; c2 = constr -> + (Some (occs,c1), c2) ] ] + ; + occs_nums: + [ [ nl = LIST1 nat_or_var -> OnlyOccurrences nl + | "-"; n = nat_or_var; nl = LIST0 int_or_var -> + (* have used int_or_var instead of nat_or_var for compatibility *) + AllOccurrencesBut (List.map (map_int_or_var abs) (n::nl)) ] ] + ; + occs: + [ [ "at"; occs = occs_nums -> occs | -> AllOccurrences ] ] + ; + pattern_occ: + [ [ c = constr; nl = occs -> (nl,c) ] ] + ; + ref_or_pattern_occ: + (* If a string, it is interpreted as a ref + (anyway a Coq string does not reduce) *) + [ [ c = smart_global; nl = occs -> nl,Inl c + | c = constr; nl = occs -> nl,Inr c ] ] + ; + unfold_occ: + [ [ c = smart_global; nl = occs -> (nl,c) ] ] + ; + intropatterns: + [ [ l = LIST0 nonsimple_intropattern -> l ]] + ; + ne_intropatterns: + [ [ l = LIST1 nonsimple_intropattern -> l ]] + ; + or_and_intropattern: + [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> IntroOrPattern tc + | "()" -> IntroAndPattern [] + | "("; si = simple_intropattern; ")" -> IntroAndPattern [si] + | "("; si = simple_intropattern; ","; + tc = LIST1 simple_intropattern SEP "," ; ")" -> + IntroAndPattern (si::tc) + | "("; si = simple_intropattern; "&"; + tc = LIST1 simple_intropattern SEP "&" ; ")" -> + (* (A & B & C) is translated into (A,(B,C)) *) + let rec pairify = function + | ([]|[_]|[_;_]) as l -> l + | t::q -> [t;(loc_of_ne_list q,IntroAction (IntroOrAndPattern (IntroAndPattern (pairify q))))] + in IntroAndPattern (pairify (si::tc)) ] ] + ; + equality_intropattern: + [ [ "->" -> IntroRewrite true + | "<-" -> IntroRewrite false + | "[="; tc = intropatterns; "]" -> IntroInjection tc ] ] + ; + naming_intropattern: + [ [ prefix = pattern_ident -> IntroFresh prefix + | "?" -> IntroAnonymous + | id = ident -> IntroIdentifier id ] ] + ; + nonsimple_intropattern: + [ [ l = simple_intropattern -> l + | "*" -> !@loc, IntroForthcoming true + | "**" -> !@loc, IntroForthcoming false ]] + ; + simple_intropattern: + [ [ pat = simple_intropattern_closed; + l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> + let loc0,pat = pat in + let f c pat = + let loc = Loc.merge loc0 (Constrexpr_ops.constr_loc c) in + IntroAction (IntroApplyOn (c,(loc,pat))) in + !@loc, List.fold_right f l pat ] ] + ; + simple_intropattern_closed: + [ [ pat = or_and_intropattern -> !@loc, IntroAction (IntroOrAndPattern pat) + | pat = equality_intropattern -> !@loc, IntroAction pat + | "_" -> !@loc, IntroAction IntroWildcard + | pat = naming_intropattern -> !@loc, IntroNaming pat ] ] + ; + simple_binding: + [ [ "("; id = ident; ":="; c = lconstr; ")" -> (!@loc, NamedHyp id, c) + | "("; n = natural; ":="; c = lconstr; ")" -> (!@loc, AnonHyp n, c) ] ] + ; + bindings: + [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> + ExplicitBindings bl + | bl = LIST1 constr -> ImplicitBindings bl ] ] + ; + constr_with_bindings: + [ [ c = constr; l = with_bindings -> (c, l) ] ] + ; + with_bindings: + [ [ "with"; bl = bindings -> bl | -> NoBindings ] ] + ; + red_flags: + [ [ IDENT "beta" -> [FBeta] + | IDENT "iota" -> [FMatch;FFix;FCofix] + | IDENT "match" -> [FMatch] + | IDENT "fix" -> [FFix] + | IDENT "cofix" -> [FCofix] + | IDENT "zeta" -> [FZeta] + | IDENT "delta"; d = delta_flag -> [d] + ] ] + ; + delta_flag: + [ [ "-"; "["; idl = LIST1 smart_global; "]" -> FDeltaBut idl + | "["; idl = LIST1 smart_global; "]" -> FConst idl + | -> FDeltaBut [] + ] ] + ; + strategy_flag: + [ [ s = LIST1 red_flags -> Redops.make_red_flag (List.flatten s) + | d = delta_flag -> all_with d + ] ] + ; + red_expr: + [ [ IDENT "red" -> Red false + | IDENT "hnf" -> Hnf + | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ -> Simpl (all_with d,po) + | IDENT "cbv"; s = strategy_flag -> Cbv s + | IDENT "cbn"; s = strategy_flag -> Cbn s + | IDENT "lazy"; s = strategy_flag -> Lazy s + | IDENT "compute"; delta = delta_flag -> Cbv (all_with delta) + | IDENT "vm_compute"; po = OPT ref_or_pattern_occ -> CbvVm po + | IDENT "native_compute"; po = OPT ref_or_pattern_occ -> CbvNative po + | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul + | IDENT "fold"; cl = LIST1 constr -> Fold cl + | IDENT "pattern"; pl = LIST1 pattern_occ SEP"," -> Pattern pl + | s = IDENT -> ExtraRedExpr s ] ] + ; + hypident: + [ [ id = id_or_meta -> + id,InHyp + | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" -> + id,InHypTypeOnly + | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" -> + id,InHypValueOnly + ] ] + ; + hypident_occ: + [ [ (id,l)=hypident; occs=occs -> ((occs,id),l) ] ] + ; + in_clause: + [ [ "*"; occs=occs -> + {onhyps=None; concl_occs=occs} + | "*"; "|-"; occs=concl_occ -> + {onhyps=None; concl_occs=occs} + | hl=LIST0 hypident_occ SEP","; "|-"; occs=concl_occ -> + {onhyps=Some hl; concl_occs=occs} + | hl=LIST0 hypident_occ SEP"," -> + {onhyps=Some hl; concl_occs=NoOccurrences} ] ] + ; + clause_dft_concl: + [ [ "in"; cl = in_clause -> cl + | occs=occs -> {onhyps=Some[]; concl_occs=occs} + | -> all_concl_occs_clause ] ] + ; + clause_dft_all: + [ [ "in"; cl = in_clause -> cl + | -> {onhyps=None; concl_occs=AllOccurrences} ] ] + ; + opt_clause: + [ [ "in"; cl = in_clause -> Some cl + | "at"; occs = occs_nums -> Some {onhyps=Some[]; concl_occs=occs} + | -> None ] ] + ; + concl_occ: + [ [ "*"; occs = occs -> occs + | -> NoOccurrences ] ] + ; + in_hyp_list: + [ [ "in"; idl = LIST1 id_or_meta -> idl + | -> [] ] ] + ; + in_hyp_as: + [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (id,ipat) + | -> None ] ] + ; + orient: + [ [ "->" -> true + | "<-" -> false + | -> true ]] + ; + simple_binder: + [ [ na=name -> ([na],Default Explicit,CHole (!@loc, Some (Evar_kinds.BinderType (snd na)), IntroAnonymous, None)) + | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> (nal,Default Explicit,c) + ] ] + ; + fixdecl: + [ [ "("; id = ident; bl=LIST0 simple_binder; ann=fixannot; + ":"; ty=lconstr; ")" -> (!@loc, id, bl, ann, ty) ] ] + ; + fixannot: + [ [ "{"; IDENT "struct"; id=name; "}" -> Some id + | -> None ] ] + ; + cofixdecl: + [ [ "("; id = ident; bl=LIST0 simple_binder; ":"; ty=lconstr; ")" -> + (!@loc, id, bl, None, ty) ] ] + ; + bindings_with_parameters: + [ [ check_for_coloneq; "("; id = ident; bl = LIST0 simple_binder; + ":="; c = lconstr; ")" -> (id, mkCLambdaN_simple bl c) ] ] + ; + eliminator: + [ [ "using"; el = constr_with_bindings -> el ] ] + ; + as_ipat: + [ [ "as"; ipat = simple_intropattern -> Some ipat + | -> None ] ] + ; + or_and_intropattern_loc: + [ [ ipat = or_and_intropattern -> ArgArg (!@loc,ipat) + | locid = identref -> ArgVar locid ] ] + ; + as_or_and_ipat: + [ [ "as"; ipat = or_and_intropattern_loc -> Some ipat + | -> None ] ] + ; + eqn_ipat: + [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> Some (!@loc, pat) + | IDENT "_eqn"; ":"; pat = naming_intropattern -> + let loc = !@loc in + warn_deprecated_eqn_syntax ~loc "H"; Some (loc, pat) + | IDENT "_eqn" -> + let loc = !@loc in + warn_deprecated_eqn_syntax ~loc "?"; Some (loc, IntroAnonymous) + | -> None ] ] + ; + as_name: + [ [ "as"; id = ident -> Names.Name id | -> Names.Anonymous ] ] + ; + by_tactic: + [ [ "by"; tac = tactic_expr LEVEL "3" -> Some tac + | -> None ] ] + ; + rewriter : + [ [ "!"; c = constr_with_bindings_arg -> (RepeatPlus,c) + | ["?"| LEFTQMARK]; c = constr_with_bindings_arg -> (RepeatStar,c) + | n = natural; "!"; c = constr_with_bindings_arg -> (Precisely n,c) + | n = natural; ["?" | LEFTQMARK]; c = constr_with_bindings_arg -> (UpTo n,c) + | n = natural; c = constr_with_bindings_arg -> (Precisely n,c) + | c = constr_with_bindings_arg -> (Precisely 1, c) + ] ] + ; + oriented_rewriter : + [ [ b = orient; p = rewriter -> let (m,c) = p in (b,m,c) ] ] + ; + induction_clause: + [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; + cl = opt_clause -> (c,(eq,pat),cl) ] ] + ; + induction_clause_list: + [ [ ic = LIST1 induction_clause SEP ","; el = OPT eliminator; + cl_tolerance = opt_clause -> + (* Condition for accepting "in" at the end by compatibility *) + match ic,el,cl_tolerance with + | [c,pat,None],Some _,Some _ -> ([c,pat,cl_tolerance],el) + | _,_,Some _ -> err () + | _,_,None -> (ic,el) ]] + ; + simple_tactic: + [ [ + (* Basic tactics *) + IDENT "intros"; pl = ne_intropatterns -> + TacAtom (!@loc, TacIntroPattern (false,pl)) + | IDENT "intros" -> + TacAtom (!@loc, TacIntroPattern (false,[!@loc,IntroForthcoming false])) + | IDENT "eintros"; pl = ne_intropatterns -> + TacAtom (!@loc, TacIntroPattern (true,pl)) + + | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; + inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,false,cl,inhyp)) + | IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP ","; + inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,true,cl,inhyp)) + | IDENT "simple"; IDENT "apply"; + cl = LIST1 constr_with_bindings_arg SEP ","; + inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,false,cl,inhyp)) + | IDENT "simple"; IDENT "eapply"; + cl = LIST1 constr_with_bindings_arg SEP","; + inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,true,cl,inhyp)) + | IDENT "elim"; cl = constr_with_bindings_arg; el = OPT eliminator -> + TacAtom (!@loc, TacElim (false,cl,el)) + | IDENT "eelim"; cl = constr_with_bindings_arg; el = OPT eliminator -> + TacAtom (!@loc, TacElim (true,cl,el)) + | IDENT "case"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase false icl) + | IDENT "ecase"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase true icl) + | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> + TacAtom (!@loc, TacMutualFix (id,n,List.map mk_fix_tac fd)) + | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> + TacAtom (!@loc, TacMutualCofix (id,List.map mk_cofix_tac fd)) + + | IDENT "pose"; (id,b) = bindings_with_parameters -> + TacAtom (!@loc, TacLetTac (Names.Name id,b,Locusops.nowhere,true,None)) + | IDENT "pose"; b = constr; na = as_name -> + TacAtom (!@loc, TacLetTac (na,b,Locusops.nowhere,true,None)) + | IDENT "set"; (id,c) = bindings_with_parameters; p = clause_dft_concl -> + TacAtom (!@loc, TacLetTac (Names.Name id,c,p,true,None)) + | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl -> + TacAtom (!@loc, TacLetTac (na,c,p,true,None)) + | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat; + p = clause_dft_all -> + TacAtom (!@loc, TacLetTac (na,c,p,false,e)) + + (* Alternative syntax for "pose proof c as id" *) + | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":="; + c = lconstr; ")" -> + TacAtom (!@loc, TacAssert (true,None,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) + + (* Alternative syntax for "assert c as id by tac" *) + | IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> + TacAtom (!@loc, TacAssert (true,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) + + (* Alternative syntax for "enough c as id by tac" *) + | IDENT "enough"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> + TacAtom (!@loc, TacAssert (false,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) + + | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> + TacAtom (!@loc, TacAssert (true,Some tac,ipat,c)) + | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> + TacAtom (!@loc, TacAssert (true,None,ipat,c)) + | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic -> + TacAtom (!@loc, TacAssert (false,Some tac,ipat,c)) + + | IDENT "generalize"; c = constr -> + TacAtom (!@loc, TacGeneralize [((AllOccurrences,c),Names.Anonymous)]) + | IDENT "generalize"; c = constr; l = LIST1 constr -> + let gen_everywhere c = ((AllOccurrences,c),Names.Anonymous) in + TacAtom (!@loc, TacGeneralize (List.map gen_everywhere (c::l))) + | IDENT "generalize"; c = constr; lookup_at_as_comma; nl = occs; + na = as_name; + l = LIST0 [","; c = pattern_occ; na = as_name -> (c,na)] -> + TacAtom (!@loc, TacGeneralize (((nl,c),na)::l)) + + (* Derived basic tactics *) + | IDENT "induction"; ic = induction_clause_list -> + TacAtom (!@loc, TacInductionDestruct (true,false,ic)) + | IDENT "einduction"; ic = induction_clause_list -> + TacAtom (!@loc, TacInductionDestruct(true,true,ic)) + | IDENT "destruct"; icl = induction_clause_list -> + TacAtom (!@loc, TacInductionDestruct(false,false,icl)) + | IDENT "edestruct"; icl = induction_clause_list -> + TacAtom (!@loc, TacInductionDestruct(false,true,icl)) + + (* Equality and inversion *) + | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; + cl = clause_dft_concl; t=by_tactic -> TacAtom (!@loc, TacRewrite (false,l,cl,t)) + | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; + cl = clause_dft_concl; t=by_tactic -> TacAtom (!@loc, TacRewrite (true,l,cl,t)) + | IDENT "dependent"; k = + [ IDENT "simple"; IDENT "inversion" -> SimpleInversion + | IDENT "inversion" -> FullInversion + | IDENT "inversion_clear" -> FullInversionClear ]; + hyp = quantified_hypothesis; + ids = as_or_and_ipat; co = OPT ["with"; c = constr -> c] -> + TacAtom (!@loc, TacInversion (DepInversion (k,co,ids),hyp)) + | IDENT "simple"; IDENT "inversion"; + hyp = quantified_hypothesis; ids = as_or_and_ipat; + cl = in_hyp_list -> + TacAtom (!@loc, TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) + | IDENT "inversion"; + hyp = quantified_hypothesis; ids = as_or_and_ipat; + cl = in_hyp_list -> + TacAtom (!@loc, TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) + | IDENT "inversion_clear"; + hyp = quantified_hypothesis; ids = as_or_and_ipat; + cl = in_hyp_list -> + TacAtom (!@loc, TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) + | IDENT "inversion"; hyp = quantified_hypothesis; + "using"; c = constr; cl = in_hyp_list -> + TacAtom (!@loc, TacInversion (InversionUsing (c,cl), hyp)) + + (* Conversion *) + | IDENT "red"; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Red false, cl)) + | IDENT "hnf"; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Hnf, cl)) + | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Simpl (all_with d, po), cl)) + | IDENT "cbv"; s = strategy_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Cbv s, cl)) + | IDENT "cbn"; s = strategy_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Cbn s, cl)) + | IDENT "lazy"; s = strategy_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Lazy s, cl)) + | IDENT "compute"; delta = delta_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Cbv (all_with delta), cl)) + | IDENT "vm_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (CbvVm po, cl)) + | IDENT "native_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (CbvNative po, cl)) + | IDENT "unfold"; ul = LIST1 unfold_occ SEP ","; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Unfold ul, cl)) + | IDENT "fold"; l = LIST1 constr; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Fold l, cl)) + | IDENT "pattern"; pl = LIST1 pattern_occ SEP","; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Pattern pl, cl)) + + (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) + | IDENT "change"; (oc,c) = conversion; cl = clause_dft_concl -> + let p,cl = merge_occurrences (!@loc) cl oc in + TacAtom (!@loc, TacChange (p,c,cl)) + ] ] + ; +END;; diff --git a/plugins/ltac/ltac_plugin.mllib b/plugins/ltac/ltac_plugin.mllib new file mode 100644 index 000000000..af1c7149d --- /dev/null +++ b/plugins/ltac/ltac_plugin.mllib @@ -0,0 +1,27 @@ +Tacarg +Pptactic +Pltac +Taccoerce +Tacsubst +Tacenv +Tactic_debug +Tacintern +Tacentries +Profile_ltac +Tactic_matching +Tacinterp +Evar_tactics +Tactic_option +Extraargs +G_obligations +Coretactics +Extratactics +Profile_ltac_tactics +G_auto +G_class +Rewrite +G_rewrite +Tauto +G_eqdecide +G_tactic +G_ltac diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml new file mode 100644 index 000000000..1d21118ae --- /dev/null +++ b/plugins/ltac/pltac.ml @@ -0,0 +1,65 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Gram.entry table *) +(* Typically for tactic user extensions *) +let open_constr = + make_gen_entry utactic "open_constr" +let constr_with_bindings = + make_gen_entry utactic "constr_with_bindings" +let bindings = + make_gen_entry utactic "bindings" +let hypident = Gram.entry_create "hypident" +let constr_may_eval = make_gen_entry utactic "constr_may_eval" +let constr_eval = make_gen_entry utactic "constr_eval" +let uconstr = + make_gen_entry utactic "uconstr" +let quantified_hypothesis = + make_gen_entry utactic "quantified_hypothesis" +let destruction_arg = make_gen_entry utactic "destruction_arg" +let int_or_var = make_gen_entry utactic "int_or_var" +let simple_intropattern = + make_gen_entry utactic "simple_intropattern" +let in_clause = make_gen_entry utactic "in_clause" +let clause_dft_concl = + make_gen_entry utactic "clause" + + +(* Main entries for ltac *) +let tactic_arg = Gram.entry_create "tactic:tactic_arg" +let tactic_expr = make_gen_entry utactic "tactic_expr" +let binder_tactic = make_gen_entry utactic "binder_tactic" + +let tactic = make_gen_entry utactic "tactic" + +(* Main entry for quotations *) +let tactic_eoi = eoi_entry tactic + +let () = + let open Stdarg in + let open Tacarg in + register_grammar wit_int_or_var (int_or_var); + register_grammar wit_intro_pattern (simple_intropattern); + register_grammar wit_quant_hyp (quantified_hypothesis); + register_grammar wit_uconstr (uconstr); + register_grammar wit_open_constr (open_constr); + register_grammar wit_constr_with_bindings (constr_with_bindings); + register_grammar wit_bindings (bindings); + register_grammar wit_tactic (tactic); + register_grammar wit_ltac (tactic); + register_grammar wit_clause_dft_concl (clause_dft_concl); + register_grammar wit_destruction_arg (destruction_arg); + () diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli new file mode 100644 index 000000000..810e1ec39 --- /dev/null +++ b/plugins/ltac/pltac.mli @@ -0,0 +1,38 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* std_ppcmds) -> + (constr_expr -> std_ppcmds) -> + (tolerability -> raw_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +type 'a glob_extra_genarg_printer = + (glob_constr_and_expr -> std_ppcmds) -> + (glob_constr_and_expr -> std_ppcmds) -> + (tolerability -> glob_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +type 'a extra_genarg_printer = + (Term.constr -> std_ppcmds) -> + (Term.constr -> std_ppcmds) -> + (tolerability -> Val.t -> std_ppcmds) -> + 'a -> std_ppcmds + +module Make + (Ppconstr : Ppconstrsig.Pp) + (Taggers : sig + val tag_keyword + : std_ppcmds -> std_ppcmds + val tag_primitive + : std_ppcmds -> std_ppcmds + val tag_string + : std_ppcmds -> std_ppcmds + val tag_glob_tactic_expr + : glob_tactic_expr -> std_ppcmds -> std_ppcmds + val tag_glob_atomic_tactic_expr + : glob_atomic_tactic_expr -> std_ppcmds -> std_ppcmds + val tag_raw_tactic_expr + : raw_tactic_expr -> std_ppcmds -> std_ppcmds + val tag_raw_atomic_tactic_expr + : raw_atomic_tactic_expr -> std_ppcmds -> std_ppcmds + val tag_atomic_tactic_expr + : atomic_tactic_expr -> std_ppcmds -> std_ppcmds + end) += struct + + open Taggers + + let keyword x = tag_keyword (str x) + let primitive x = tag_primitive (str x) + + let has_type (Val.Dyn (tag, x)) t = match Val.eq tag t with + | None -> false + | Some _ -> true + + let unbox : type a. Val.t -> a Val.typ -> a= fun (Val.Dyn (tag, x)) t -> + match Val.eq tag t with + | None -> assert false + | Some Refl -> x + + let rec pr_value lev v : std_ppcmds = + if has_type v Val.typ_list then + pr_sequence (fun x -> pr_value lev x) (unbox v Val.typ_list) + else if has_type v Val.typ_opt then + pr_opt_no_spc (fun x -> pr_value lev x) (unbox v Val.typ_opt) + else if has_type v Val.typ_pair then + let (v1, v2) = unbox v Val.typ_pair in + str "(" ++ pr_value lev v1 ++ str ", " ++ pr_value lev v2 ++ str ")" + else + let Val.Dyn (tag, x) = v in + let name = Val.repr tag in + let default = str "<" ++ str name ++ str ">" in + match ArgT.name name with + | None -> default + | Some (ArgT.Any arg) -> + let wit = ExtraArg arg in + match val_tag (Topwit wit) with + | Val.Base t -> + begin match Val.eq t tag with + | None -> default + | Some Refl -> Genprint.generic_top_print (in_gen (Topwit wit) x) + end + | _ -> default + + let pr_with_occurrences pr c = pr_with_occurrences pr keyword c + let pr_red_expr pr c = pr_red_expr pr keyword c + + let pr_may_eval test prc prlc pr2 pr3 = function + | ConstrEval (r,c) -> + hov 0 + (keyword "eval" ++ brk (1,1) ++ + pr_red_expr (prc,prlc,pr2,pr3) r ++ spc () ++ + keyword "in" ++ spc() ++ prc c) + | ConstrContext ((_,id),c) -> + hov 0 + (keyword "context" ++ spc () ++ pr_id id ++ spc () ++ + str "[ " ++ prlc c ++ str " ]") + | ConstrTypeOf c -> + hov 1 (keyword "type of" ++ spc() ++ prc c) + | ConstrTerm c when test c -> + h 0 (str "(" ++ prc c ++ str ")") + | ConstrTerm c -> + prc c + + let pr_may_eval a = + pr_may_eval (fun _ -> false) a + + let pr_arg pr x = spc () ++ pr x + + let pr_and_short_name pr (c,_) = pr c + + let pr_or_by_notation f = function + | AN v -> f v + | ByNotation (_,s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc + + let pr_located pr (loc,x) = pr x + + let pr_evaluable_reference = function + | EvalVarRef id -> pr_id id + | EvalConstRef sp -> pr_global (Globnames.ConstRef sp) + + let pr_quantified_hypothesis = function + | AnonHyp n -> int n + | NamedHyp id -> pr_id id + + let pr_binding prc = function + | loc, NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c) + | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) + + let pr_bindings prc prlc = function + | ImplicitBindings l -> + brk (1,1) ++ keyword "with" ++ brk (1,1) ++ + hv 0 (prlist_with_sep spc prc l) + | ExplicitBindings l -> + brk (1,1) ++ keyword "with" ++ brk (1,1) ++ + hv 0 (prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l) + | NoBindings -> mt () + + let pr_bindings_no_with prc prlc = function + | ImplicitBindings l -> + brk (0,1) ++ + prlist_with_sep spc prc l + | ExplicitBindings l -> + brk (0,1) ++ + prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l + | NoBindings -> mt () + + let pr_clear_flag clear_flag pp x = + match clear_flag with + | Some false -> surround (pp x) + | Some true -> str ">" ++ pp x + | None -> pp x + + let pr_with_bindings prc prlc (c,bl) = + prc c ++ pr_bindings prc prlc bl + + let pr_with_bindings_arg prc prlc (clear_flag,c) = + pr_clear_flag clear_flag (pr_with_bindings prc prlc) c + + let pr_with_constr prc = function + | None -> mt () + | Some c -> spc () ++ hov 1 (keyword "with" ++ spc () ++ prc c) + + let pr_message_token prid = function + | MsgString s -> tag_string (qs s) + | MsgInt n -> int n + | MsgIdent id -> prid id + + let pr_fresh_ids = + prlist (fun s -> spc() ++ pr_or_var (fun s -> tag_string (qs s)) s) + + let with_evars ev s = if ev then "e" ^ s else s + + let rec tacarg_using_rule_token pr_gen = function + | [] -> [] + | TacTerm s :: l -> keyword s :: tacarg_using_rule_token pr_gen l + | TacNonTerm (_, (symb, arg), _) :: l -> + pr_gen symb arg :: tacarg_using_rule_token pr_gen l + + let pr_tacarg_using_rule pr_gen l = + let l = match l with + | TacTerm s :: l -> + (** First terminal token should be considered as the name of the tactic, + so we tag it differently than the other terminal tokens. *) + primitive s :: tacarg_using_rule_token pr_gen l + | _ -> tacarg_using_rule_token pr_gen l + in + pr_sequence (fun x -> x) l + + let pr_extend_gen pr_gen lev { mltac_name = s; mltac_index = i } l = + let name = + str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic ++ + str "@" ++ int i + in + let args = match l with + | [] -> mt () + | _ -> spc() ++ pr_sequence pr_gen l + in + str "<" ++ name ++ str ">" ++ args + + let rec pr_user_symbol = function + | Extend.Ulist1 tkn -> "ne_" ^ pr_user_symbol tkn ^ "_list" + | Extend.Ulist1sep (tkn, _) -> "ne_" ^ pr_user_symbol tkn ^ "_list" + | Extend.Ulist0 tkn -> pr_user_symbol tkn ^ "_list" + | Extend.Ulist0sep (tkn, _) -> pr_user_symbol tkn ^ "_list" + | Extend.Uopt tkn -> pr_user_symbol tkn ^ "_opt" + | Extend.Uentry tag -> + let ArgT.Any tag = tag in + ArgT.repr tag + | Extend.Uentryl (tkn, lvl) -> "tactic" ^ string_of_int lvl + + let pr_alias_key key = + try + let prods = (KNmap.find key !prnotation_tab).pptac_prods in + let rec pr = function + | TacTerm s -> primitive s + | TacNonTerm (_, symb, _) -> str (Printf.sprintf "(%s)" (pr_user_symbol symb)) + in + pr_sequence pr prods + with Not_found -> + KerName.print key + + let pr_alias_gen pr_gen lev key l = + try + let pp = KNmap.find key !prnotation_tab in + let rec pack prods args = match prods, args with + | [], [] -> [] + | TacTerm s :: prods, args -> TacTerm s :: pack prods args + | TacNonTerm (loc, symb, id) :: prods, arg :: args -> + TacNonTerm (loc, (symb, arg), id) :: pack prods args + | _ -> raise Not_found + in + let prods = pack pp.pptac_prods l in + let p = pr_tacarg_using_rule pr_gen prods in + if pp.pptac_level > lev then surround p else p + with Not_found -> + let pr arg = str "_" in + KerName.print key ++ spc() ++ pr_sequence pr l ++ str" (* Generic printer *)" + + let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.ghost, arg)) + + let is_genarg tag wit = + let ArgT.Any tag = tag in + argument_type_eq (ArgumentType (ExtraArg tag)) wit + + let get_list : type l. l generic_argument -> l generic_argument list option = + function (GenArg (wit, arg)) -> match wit with + | Rawwit (ListArg wit) -> Some (List.map (in_gen (rawwit wit)) arg) + | Glbwit (ListArg wit) -> Some (List.map (in_gen (glbwit wit)) arg) + | _ -> None + + let get_opt : type l. l generic_argument -> l generic_argument option option = + function (GenArg (wit, arg)) -> match wit with + | Rawwit (OptArg wit) -> Some (Option.map (in_gen (rawwit wit)) arg) + | Glbwit (OptArg wit) -> Some (Option.map (in_gen (glbwit wit)) arg) + | _ -> None + + let rec pr_any_arg : type l. (_ -> l generic_argument -> std_ppcmds) -> _ -> l generic_argument -> std_ppcmds = + fun prtac symb arg -> match symb with + | Extend.Uentry tag when is_genarg tag (genarg_tag arg) -> prtac (1, Any) arg + | Extend.Ulist1 s | Extend.Ulist0 s -> + begin match get_list arg with + | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" + | Some l -> pr_sequence (pr_any_arg prtac s) l + end + | Extend.Ulist1sep (s, sep) | Extend.Ulist0sep (s, sep) -> + begin match get_list arg with + | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" + | Some l -> prlist_with_sep (fun () -> str sep) (pr_any_arg prtac s) l + end + | Extend.Uopt s -> + begin match get_opt arg with + | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" + | Some l -> pr_opt (pr_any_arg prtac s) l + end + | Extend.Uentry _ | Extend.Uentryl _ -> + str "ltac:(" ++ prtac (1, Any) arg ++ str ")" + + let rec pr_targ prtac symb arg = match symb with + | Extend.Uentry tag when is_genarg tag (ArgumentType wit_tactic) -> + prtac (1, Any) arg + | Extend.Uentryl (_, l) -> prtac (l, Any) arg + | _ -> + match arg with + | TacGeneric arg -> + let pr l arg = prtac l (TacGeneric arg) in + pr_any_arg pr symb arg + | _ -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" + + let pr_raw_extend_rec prc prlc prtac prpat = + pr_extend_gen (pr_farg prtac) + let pr_glob_extend_rec prc prlc prtac prpat = + pr_extend_gen (pr_farg prtac) + + let pr_raw_alias prc prlc prtac prpat lev key args = + pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args + let pr_glob_alias prc prlc prtac prpat lev key args = + pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args + + (**********************************************************************) + (* The tactic printer *) + + let strip_prod_binders_expr n ty = + let rec strip_ty acc n ty = + match ty 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 + if nb >= n then (List.rev (bll@acc)), a + else strip_ty (bll@acc) (n-nb) a + | _ -> error "Cannot translate fix tactic: not enough products" in + strip_ty [] n ty + + let pr_ltac_or_var pr = function + | ArgArg x -> pr x + | ArgVar (loc,id) -> pr_with_comments loc (pr_id id) + + let pr_ltac_constant kn = + if !Flags.in_debugger then pr_kn kn + else try + pr_qualid (Nametab.shortest_qualid_of_tactic kn) + with Not_found -> (* local tactic not accessible anymore *) + str "<" ++ pr_kn kn ++ str ">" + + let pr_evaluable_reference_env env = function + | EvalVarRef id -> pr_id id + | EvalConstRef sp -> + Nametab.pr_global_env (Termops.vars_of_env env) (Globnames.ConstRef sp) + + let pr_esubst prc l = + let pr_qhyp = function + (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")" + | (_,NamedHyp id,c) -> + str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")" + in + prlist_with_sep spc pr_qhyp l + + let pr_bindings_gen for_ex prc prlc = function + | ImplicitBindings l -> + spc () ++ + hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++ + prlist_with_sep spc prc l) + | ExplicitBindings l -> + spc () ++ + hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++ + pr_esubst prlc l) + | NoBindings -> mt () + + let pr_bindings prc prlc = pr_bindings_gen false prc prlc + + let pr_with_bindings prc prlc (c,bl) = + hov 1 (prc c ++ pr_bindings prc prlc bl) + + let pr_as_disjunctive_ipat prc ipatl = + keyword "as" ++ spc () ++ + pr_or_var (fun (loc,p) -> Miscprint.pr_or_and_intro_pattern prc p) ipatl + + let pr_eqn_ipat (_,ipat) = keyword "eqn:" ++ Miscprint.pr_intro_pattern_naming ipat + + let pr_with_induction_names prc = function + | None, None -> mt () + | Some eqpat, None -> hov 1 (pr_eqn_ipat eqpat) + | None, Some ipat -> hov 1 (pr_as_disjunctive_ipat prc ipat) + | Some eqpat, Some ipat -> + hov 1 (pr_as_disjunctive_ipat prc ipat ++ spc () ++ pr_eqn_ipat eqpat) + + let pr_as_intro_pattern prc ipat = + spc () ++ hov 1 (keyword "as" ++ spc () ++ Miscprint.pr_intro_pattern prc ipat) + + let pr_with_inversion_names prc = function + | None -> mt () + | Some ipat -> pr_as_disjunctive_ipat prc ipat + + let pr_as_ipat prc = function + | None -> mt () + | Some ipat -> pr_as_intro_pattern prc ipat + + let pr_as_name = function + | Anonymous -> mt () + | Name id -> spc () ++ keyword "as" ++ spc () ++ pr_lident (Loc.ghost,id) + + let pr_pose_as_style prc na c = + spc() ++ prc c ++ pr_as_name na + + let pr_pose prc prlc na c = match na with + | Anonymous -> spc() ++ prc c + | Name id -> spc() ++ surround (pr_id id ++ str " :=" ++ spc() ++ prlc c) + + let pr_assertion prc prdc _prlc ipat c = match ipat with + (* Use this "optimisation" or use only the general case ? + | IntroIdentifier id -> + spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c) + *) + | ipat -> + spc() ++ prc c ++ pr_as_ipat prdc ipat + + let pr_assumption prc prdc prlc ipat c = match ipat with + (* Use this "optimisation" or use only the general case ?*) + (* it seems that this "optimisation" is somehow more natural *) + | Some (_,IntroNaming (IntroIdentifier id)) -> + spc() ++ surround (pr_id id ++ str " :" ++ spc() ++ prlc c) + | ipat -> + spc() ++ prc c ++ pr_as_ipat prdc ipat + + let pr_by_tactic prt = function + | Some tac -> keyword "by" ++ spc () ++ prt tac + | None -> mt() + + let pr_hyp_location pr_id = function + | occs, InHyp -> pr_with_occurrences pr_id occs + | occs, InHypTypeOnly -> + pr_with_occurrences (fun id -> + str "(" ++ keyword "type of" ++ spc () ++ pr_id id ++ str ")" + ) occs + | occs, InHypValueOnly -> + pr_with_occurrences (fun id -> + str "(" ++ keyword "value of" ++ spc () ++ pr_id id ++ str ")" + ) occs + + let pr_in pp = hov 0 (keyword "in" ++ pp) + + let pr_simple_hyp_clause pr_id = function + | [] -> mt () + | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l) + + let pr_in_hyp_as prc pr_id = function + | None -> mt () + | Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat + + let pr_in_clause pr_id = function + | { onhyps=None; concl_occs=NoOccurrences } -> + (str "* |-") + | { onhyps=None; concl_occs=occs } -> + (pr_with_occurrences (fun () -> str "*") (occs,())) + | { onhyps=Some l; concl_occs=NoOccurrences } -> + prlist_with_sep (fun () -> str ", ") (pr_hyp_location pr_id) l + | { onhyps=Some l; concl_occs=occs } -> + let pr_occs = pr_with_occurrences (fun () -> str" |- *") (occs,()) in + (prlist_with_sep (fun () -> str", ") (pr_hyp_location pr_id) l ++ pr_occs) + + let pr_clauses default_is_concl pr_id = function + | { onhyps=Some []; concl_occs=occs } + when (match default_is_concl with Some true -> true | _ -> false) -> + pr_with_occurrences mt (occs,()) + | { onhyps=None; concl_occs=AllOccurrences } + when (match default_is_concl with Some false -> true | _ -> false) -> mt () + | { onhyps=None; concl_occs=NoOccurrences } -> + pr_in (str " * |-") + | { onhyps=None; concl_occs=occs } -> + pr_in (pr_with_occurrences (fun () -> str " *") (occs,())) + | { onhyps=Some l; concl_occs=occs } -> + let pr_occs = match occs with + | NoOccurrences -> mt () + | _ -> pr_with_occurrences (fun () -> str" |- *") (occs,()) + in + pr_in + (prlist_with_sep (fun () -> str",") + (fun id -> spc () ++ pr_hyp_location pr_id id) l ++ pr_occs) + + let pr_orient b = if b then mt () else str "<- " + + let pr_multi = function + | Precisely 1 -> mt () + | Precisely n -> int n ++ str "!" + | UpTo n -> int n ++ str "?" + | RepeatStar -> str "?" + | RepeatPlus -> str "!" + + let pr_core_destruction_arg prc prlc = function + | ElimOnConstr c -> pr_with_bindings prc prlc c + | ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id) + | ElimOnAnonHyp n -> int n + + let pr_destruction_arg prc prlc (clear_flag,h) = + pr_clear_flag clear_flag (pr_core_destruction_arg prc prlc) h + + let pr_inversion_kind = function + | SimpleInversion -> primitive "simple inversion" + | FullInversion -> primitive "inversion" + | FullInversionClear -> primitive "inversion_clear" + + let pr_range_selector (i, j) = + if Int.equal i j then int i + else int i ++ str "-" ++ int j + + let pr_goal_selector = function + | SelectNth i -> int i ++ str ":" + | SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ + str "]" ++ str ":" + | SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" + | SelectAll -> str "all" ++ str ":" + + let pr_lazy = function + | General -> keyword "multi" + | Select -> keyword "lazy" + | Once -> mt () + + 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. *) + keyword "context" ++ str" [ " ++ pr_pat a ++ str " ]" + | Subterm (b,Some id,a) -> + keyword "context" ++ spc () ++ pr_id id ++ str "[ " ++ pr_pat a ++ str " ]" + + let pr_match_hyps pr_pat = function + | Hyp (nal,mp) -> + pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp + | Def (nal,mv,mp) -> + pr_lname nal ++ str ":=" ++ pr_match_pattern pr_pat mv + ++ str ":" ++ pr_match_pattern pr_pat mp + + let pr_match_rule m pr pr_pat = function + | Pat ([],mp,t) when m -> + pr_match_pattern pr_pat mp ++ + spc () ++ str "=>" ++ brk (1,4) ++ pr t + (* + | Pat (rl,mp,t) -> + hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl ++ + (if rl <> [] then spc () else mt ()) ++ + hov 0 (str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ + str "=>" ++ brk (1,4) ++ pr t)) + *) + | Pat (rl,mp,t) -> + hov 0 ( + hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl) ++ + (if not (List.is_empty rl) then spc () else mt ()) ++ + hov 0 ( + str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ + str "=>" ++ brk (1,4) ++ pr t)) + | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t + + let pr_funvar = function + | None -> spc () ++ str "_" + | Some id -> spc () ++ pr_id id + + let pr_let_clause k pr (id,(bl,t)) = + hov 0 (keyword k ++ spc () ++ pr_lident id ++ prlist pr_funvar bl ++ + str " :=" ++ brk (1,1) ++ pr (TacArg (Loc.ghost,t))) + + let pr_let_clauses recflag pr = function + | hd::tl -> + hv 0 + (pr_let_clause (if recflag then "let rec" else "let") pr hd ++ + prlist (fun t -> spc () ++ pr_let_clause "with" pr t) tl) + | [] -> anomaly (Pp.str "LetIn must declare at least one binding") + + let pr_seq_body pr tl = + hv 0 (str "[ " ++ + prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++ + str " ]") + + let pr_dispatch pr tl = + hv 0 (str "[>" ++ + prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++ + str " ]") + + let pr_opt_tactic pr = function + | TacId [] -> mt () + | t -> pr t + + let pr_tac_extend_gen pr tf tm tl = + prvect_with_sep mt (fun t -> pr t ++ spc () ++ str "| ") tf ++ + pr_opt_tactic pr tm ++ str ".." ++ + prvect_with_sep mt (fun t -> spc () ++ str "| " ++ pr t) tl + + let pr_then_gen pr tf tm tl = + hv 0 (str "[ " ++ + pr_tac_extend_gen pr tf tm tl ++ + str " ]") + + let pr_tac_extend pr tf tm tl = + hv 0 (str "[>" ++ + pr_tac_extend_gen pr tf tm tl ++ + str " ]") + + let pr_hintbases = function + | None -> keyword "with" ++ str" *" + | Some [] -> mt () + | Some l -> hov 2 (keyword "with" ++ prlist (fun s -> spc () ++ str s) l) + + let pr_auto_using prc = function + | [] -> mt () + | l -> hov 2 (keyword "using" ++ spc () ++ prlist_with_sep pr_comma prc l) + + let pr_then () = str ";" + + let ltop = (5,E) + let lseq = 4 + let ltactical = 3 + let lorelse = 2 + let llet = 5 + let lfun = 5 + let lcomplete = 1 + let labstract = 3 + let lmatch = 1 + let latom = 0 + let lcall = 1 + let leval = 1 + let ltatom = 1 + let linfo = 5 + + let level_of (n,p) = match p with E -> n | L -> n-1 | Prec n -> n | Any -> lseq + + (** A printer for tactics that polymorphically works on the three + "raw", "glob" and "typed" levels *) + + type 'a printer = { + pr_tactic : tolerability -> 'tacexpr -> std_ppcmds; + pr_constr : 'trm -> std_ppcmds; + pr_lconstr : 'trm -> std_ppcmds; + pr_dconstr : 'dtrm -> std_ppcmds; + pr_pattern : 'pat -> std_ppcmds; + pr_lpattern : 'pat -> std_ppcmds; + pr_constant : 'cst -> std_ppcmds; + pr_reference : 'ref -> std_ppcmds; + pr_name : 'nam -> std_ppcmds; + pr_generic : 'lev generic_argument -> std_ppcmds; + pr_extend : int -> ml_tactic_entry -> 'a gen_tactic_arg list -> std_ppcmds; + pr_alias : int -> KerName.t -> 'a gen_tactic_arg list -> std_ppcmds; + } + + constraint 'a = < + term :'trm; + dterm :'dtrm; + pattern :'pat; + constant :'cst; + reference :'ref; + name :'nam; + tacexpr :'tacexpr; + level :'lev + > + + let pr_atom pr strip_prod_binders tag_atom = + let pr_with_bindings = pr_with_bindings pr.pr_constr pr.pr_lconstr in + let pr_with_bindings_arg_full = pr_with_bindings_arg in + let pr_with_bindings_arg = pr_with_bindings_arg pr.pr_constr pr.pr_lconstr in + let pr_red_expr = pr_red_expr (pr.pr_constr,pr.pr_lconstr,pr.pr_constant,pr.pr_pattern) in + + let _pr_constrarg c = spc () ++ pr.pr_constr c in + let pr_lconstrarg c = spc () ++ pr.pr_lconstr c in + let pr_intarg n = spc () ++ int n in + + (* Some printing combinators *) + let pr_eliminator cb = keyword "using" ++ pr_arg pr_with_bindings cb in + + let pr_binder_fix (nal,t) = + (* match t with + | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal + | _ ->*) + let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr t in + spc() ++ hov 1 (str"(" ++ s ++ str")") in + + let pr_fix_tac (id,n,c) = + let rec set_nth_name avoid n = function + (nal,ty)::bll -> + if n <= List.length nal then + match List.chop (n-1) nal with + _, (_,Name id) :: _ -> id, (nal,ty)::bll + | bef, (loc,Anonymous) :: aft -> + let id = next_ident_away (Id.of_string"y") avoid in + id, ((bef@(loc,Name id)::aft, ty)::bll) + | _ -> assert false + else + let (id,bll') = set_nth_name avoid (n-List.length nal) bll in + (id,(nal,ty)::bll') + | [] -> assert false in + let (bll,ty) = strip_prod_binders n c in + let names = + List.fold_left + (fun ln (nal,_) -> List.fold_left + (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln) + ln nal) + [] bll in + let idarg,bll = set_nth_name names n bll in + let annot = match names with + | [_] -> + mt () + | _ -> + spc() ++ str"{" + ++ keyword "struct" ++ spc () + ++ pr_id idarg ++ str"}" + in + hov 1 (str"(" ++ pr_id id ++ + prlist pr_binder_fix bll ++ annot ++ str" :" ++ + pr_lconstrarg ty ++ str")") in + (* spc() ++ + hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ _pr_constrarg + c) + *) + let pr_cofix_tac (id,c) = + hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg c ++ str")") in + + (* Printing tactics as arguments *) + let rec pr_atom0 a = tag_atom a (match a with + | TacIntroPattern (false,[]) -> primitive "intros" + | TacIntroPattern (true,[]) -> primitive "eintros" + | t -> str "(" ++ pr_atom1 t ++ str ")" + ) + + (* Main tactic printer *) + and pr_atom1 a = tag_atom a (match a with + (* Basic tactics *) + | 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) + | TacApply (a,ev,cb,inhyp) -> + hov 1 ( + (if a then mt() else primitive "simple ") ++ + primitive (with_evars ev "apply") ++ spc () ++ + prlist_with_sep pr_comma pr_with_bindings_arg cb ++ + pr_non_empty_arg (pr_in_hyp_as pr.pr_dconstr pr.pr_name) inhyp + ) + | TacElim (ev,cb,cbo) -> + hov 1 ( + primitive (with_evars ev "elim") + ++ pr_arg pr_with_bindings_arg cb + ++ pr_opt pr_eliminator cbo) + | TacCase (ev,cb) -> + hov 1 (primitive (with_evars ev "case") ++ spc () ++ pr_with_bindings_arg cb) + | TacMutualFix (id,n,l) -> + hov 1 ( + primitive "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc() + ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_fix_tac l) + | TacMutualCofix (id,l) -> + hov 1 ( + primitive "cofix" ++ spc () ++ pr_id id ++ spc() + ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_cofix_tac l + ) + | TacAssert (b,Some tac,ipat,c) -> + hov 1 ( + primitive (if b then "assert" else "enough") ++ + pr_assumption pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ++ + pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac + ) + | TacAssert (_,None,ipat,c) -> + hov 1 ( + primitive "pose proof" + ++ pr_assertion pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c + ) + | TacGeneralize l -> + hov 1 ( + primitive "generalize" ++ spc () + ++ prlist_with_sep pr_comma (fun (cl,na) -> + pr_with_occurrences pr.pr_constr cl ++ pr_as_name na) + l + ) + | TacLetTac (na,c,cl,true,_) when Locusops.is_nowhere cl -> + hov 1 (primitive "pose" ++ pr_pose pr.pr_constr pr.pr_lconstr na c) + | TacLetTac (na,c,cl,b,e) -> + hov 1 ( + (if b then primitive "set" else primitive "remember") ++ + (if b then pr_pose pr.pr_constr pr.pr_lconstr na c + else pr_pose_as_style pr.pr_constr na c) ++ + pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++ + pr_non_empty_arg (pr_clauses (Some b) pr.pr_name) cl) + (* | TacInstantiate (n,c,ConclLocation ()) -> + hov 1 (str "instantiate" ++ spc() ++ + hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++ + pr_lconstrarg c ++ str ")" )) + | TacInstantiate (n,c,HypLocation (id,hloc)) -> + hov 1 (str "instantiate" ++ spc() ++ + hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++ + pr_lconstrarg c ++ str ")" ) + ++ str "in" ++ pr_hyp_location pr.pr_name (id,[],(hloc,ref None))) + *) + + (* Derived basic tactics *) + | TacInductionDestruct (isrec,ev,(l,el)) -> + hov 1 ( + primitive (with_evars ev (if isrec then "induction" else "destruct")) + ++ spc () + ++ prlist_with_sep pr_comma (fun (h,ids,cl) -> + pr_destruction_arg pr.pr_dconstr pr.pr_dconstr h ++ + pr_non_empty_arg (pr_with_induction_names pr.pr_dconstr) ids ++ + pr_opt (pr_clauses None pr.pr_name) cl) l ++ + pr_opt pr_eliminator el + ) + + (* Conversion *) + | TacReduce (r,h) -> + hov 1 ( + pr_red_expr r + ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h + ) + | TacChange (op,c,h) -> + hov 1 ( + primitive "change" ++ brk (1,1) + ++ ( + match op with + None -> + mt () + | Some p -> + pr.pr_pattern p ++ spc () + ++ keyword "with" ++ spc () + ) ++ pr.pr_dconstr c ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h + ) + + (* Equality and inversion *) + | TacRewrite (ev,l,cl,tac) -> + hov 1 ( + primitive (with_evars ev "rewrite") ++ spc () + ++ prlist_with_sep + (fun () -> str ","++spc()) + (fun (b,m,c) -> + pr_orient b ++ pr_multi m ++ + pr_with_bindings_arg_full pr.pr_dconstr pr.pr_dconstr c) + l + ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) cl + ++ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac + ) + | TacInversion (DepInversion (k,c,ids),hyp) -> + hov 1 ( + primitive "dependent " ++ pr_inversion_kind k ++ spc () + ++ pr_quantified_hypothesis hyp + ++ pr_with_inversion_names pr.pr_dconstr ids + ++ pr_with_constr pr.pr_constr c + ) + | TacInversion (NonDepInversion (k,cl,ids),hyp) -> + hov 1 ( + pr_inversion_kind k ++ spc () + ++ pr_quantified_hypothesis hyp + ++ pr_non_empty_arg (pr_with_inversion_names pr.pr_dconstr) ids + ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl + ) + | TacInversion (InversionUsing (c,cl),hyp) -> + hov 1 ( + primitive "inversion" ++ spc() + ++ pr_quantified_hypothesis hyp ++ spc () + ++ keyword "using" ++ spc () ++ pr.pr_constr c + ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl + ) + ) + in + pr_atom1 + + let make_pr_tac pr strip_prod_binders tag_atom tag = + + let extract_binders = function + | Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body) + | body -> ([],body) in + let rec pr_tac inherited tac = + let return (doc, l) = (tag tac doc, l) in + let (strm, prec) = return (match tac with + | TacAbstract (t,None) -> + keyword "abstract " ++ pr_tac (labstract,L) t, labstract + | TacAbstract (t,Some s) -> + hov 0 ( + keyword "abstract" + ++ str" (" ++ pr_tac (labstract,L) t ++ str")" ++ spc () + ++ keyword "using" ++ spc () ++ pr_id s), + labstract + | TacLetIn (recflag,llc,u) -> + let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in + v 0 + (hv 0 ( + pr_let_clauses recflag (pr_tac ltop) llc + ++ spc () ++ keyword "in" + ) ++ fnl () ++ pr_tac (llet,E) u), + llet + | TacMatch (lz,t,lrul) -> + hov 0 ( + pr_lazy lz ++ keyword "match" ++ spc () + ++ pr_tac ltop t ++ spc () ++ keyword "with" + ++ prlist (fun r -> + fnl () ++ str "| " + ++ pr_match_rule true (pr_tac ltop) pr.pr_lpattern r + ) lrul + ++ fnl() ++ keyword "end"), + lmatch + | TacMatchGoal (lz,lr,lrul) -> + hov 0 ( + pr_lazy lz + ++ keyword (if lr then "match reverse goal with" else "match goal with") + ++ prlist (fun r -> + fnl () ++ str "| " + ++ pr_match_rule false (pr_tac ltop) pr.pr_lpattern r + ) lrul ++ fnl() ++ keyword "end"), + lmatch + | TacFun (lvar,body) -> + hov 2 ( + keyword "fun" + ++ prlist pr_funvar lvar ++ str " =>" ++ spc () + ++ pr_tac (lfun,E) body), + lfun + | TacThens (t,tl) -> + hov 1 ( + pr_tac (lseq,E) t ++ pr_then () ++ spc () + ++ pr_seq_body (pr_opt_tactic (pr_tac ltop)) tl), + lseq + | TacThen (t1,t2) -> + hov 1 ( + pr_tac (lseq,E) t1 ++ pr_then () ++ spc () + ++ pr_tac (lseq,L) t2), + lseq + | TacDispatch tl -> + pr_dispatch (pr_tac ltop) tl, lseq + | TacExtendTac (tf,t,tr) -> + pr_tac_extend (pr_tac ltop) tf t tr , lseq + | TacThens3parts (t1,tf,t2,tl) -> + hov 1 ( + pr_tac (lseq,E) t1 ++ pr_then () ++ spc () + ++ pr_then_gen (pr_tac ltop) tf t2 tl), + lseq + | TacTry t -> + hov 1 ( + keyword "try" ++ spc () ++ pr_tac (ltactical,E) t), + ltactical + | TacDo (n,t) -> + hov 1 ( + str "do" ++ spc () + ++ pr_or_var int n ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacTimeout (n,t) -> + hov 1 ( + keyword "timeout " + ++ pr_or_var int n ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacTime (s,t) -> + hov 1 ( + keyword "time" + ++ pr_opt str s ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacRepeat t -> + hov 1 ( + keyword "repeat" ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacProgress t -> + hov 1 ( + keyword "progress" ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacShowHyps t -> + hov 1 ( + keyword "infoH" ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacInfo t -> + hov 1 ( + keyword "info" ++ spc () + ++ pr_tac (ltactical,E) t), + linfo + | TacOr (t1,t2) -> + hov 1 ( + pr_tac (lorelse,L) t1 ++ spc () + ++ str "+" ++ brk (1,1) + ++ pr_tac (lorelse,E) t2), + lorelse + | TacOnce t -> + hov 1 ( + keyword "once" ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacExactlyOnce t -> + hov 1 ( + keyword "exactly_once" ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacIfThenCatch (t,tt,te) -> + hov 1 ( + str"tryif" ++ spc() ++ pr_tac (ltactical,E) t ++ brk(1,1) ++ + str"then" ++ spc() ++ pr_tac (ltactical,E) tt ++ brk(1,1) ++ + str"else" ++ spc() ++ pr_tac (ltactical,E) te ++ brk(1,1)), + ltactical + | TacOrelse (t1,t2) -> + hov 1 ( + pr_tac (lorelse,L) t1 ++ spc () + ++ str "||" ++ brk (1,1) + ++ pr_tac (lorelse,E) t2), + lorelse + | TacFail (g,n,l) -> + let arg = + match n with + | ArgArg 0 -> mt () + | _ -> pr_arg (pr_or_var int) n + in + let name = + match g with + | TacGlobal -> keyword "gfail" + | TacLocal -> keyword "fail" + in + hov 1 ( + name ++ arg + ++ prlist (pr_arg (pr_message_token pr.pr_name)) l), + latom + | TacFirst tl -> + keyword "first" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet + | TacSolve tl -> + keyword "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet + | TacComplete t -> + pr_tac (lcomplete,E) t, lcomplete + | TacSelect (s, tac) -> pr_goal_selector s ++ spc () ++ pr_tac ltop tac, latom + | TacId l -> + keyword "idtac" ++ prlist (pr_arg (pr_message_token pr.pr_name)) l, latom + | TacAtom (loc,t) -> + pr_with_comments loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom + | TacArg(_,Tacexp e) -> + pr.pr_tactic (latom,E) e, latom + | TacArg(_,ConstrMayEval (ConstrTerm c)) -> + keyword "constr:" ++ pr.pr_constr c, latom + | TacArg(_,ConstrMayEval c) -> + pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval + | TacArg(_,TacFreshId l) -> + primitive "fresh" ++ pr_fresh_ids l, latom + | TacArg(_,TacGeneric arg) -> + pr.pr_generic arg, latom + | TacArg(_,TacCall(loc,f,[])) -> + pr.pr_reference f, latom + | TacArg(_,TacCall(loc,f,l)) -> + pr_with_comments loc (hov 1 ( + pr.pr_reference f ++ spc () + ++ prlist_with_sep spc pr_tacarg l)), + lcall + | TacArg (_,a) -> + pr_tacarg a, latom + | TacML (loc,s,l) -> + pr_with_comments loc (pr.pr_extend 1 s l), lcall + | TacAlias (loc,kn,l) -> + pr_with_comments loc (pr.pr_alias (level_of inherited) kn l), latom + ) + in + if prec_less prec inherited then strm + else str"(" ++ strm ++ str")" + + and pr_tacarg = function + | Reference r -> + pr.pr_reference r + | ConstrMayEval c -> + pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c + | TacFreshId l -> + keyword "fresh" ++ pr_fresh_ids l + | TacPretype c -> + keyword "type_term" ++ pr.pr_constr c + | TacNumgoals -> + keyword "numgoals" + | (TacCall _|Tacexp _ | TacGeneric _) as a -> + hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (Loc.ghost,a)))) + + in pr_tac + + let strip_prod_binders_glob_constr n (ty,_) = + let rec strip_ty acc n ty = + if Int.equal n 0 then (List.rev acc, (ty,None)) else + match ty with + Glob_term.GProd(loc,na,Explicit,a,b) -> + strip_ty (([Loc.ghost,na],(a,None))::acc) (n-1) b + | _ -> error "Cannot translate fix tactic: not enough products" in + strip_ty [] n ty + + let raw_printers = + (strip_prod_binders_expr) + + let rec pr_raw_tactic_level n (t:raw_tactic_expr) = + let pr = { + pr_tactic = pr_raw_tactic_level; + pr_constr = pr_constr_expr; + pr_dconstr = pr_constr_expr; + pr_lconstr = pr_lconstr_expr; + pr_pattern = pr_constr_pattern_expr; + pr_lpattern = pr_lconstr_pattern_expr; + pr_constant = pr_or_by_notation pr_reference; + pr_reference = pr_reference; + pr_name = pr_lident; + pr_generic = (fun arg -> Pputils.pr_raw_generic (Global.env ()) arg); + pr_extend = pr_raw_extend_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; + pr_alias = pr_raw_alias pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; + } in + make_pr_tac + pr raw_printers + tag_raw_atomic_tactic_expr tag_raw_tactic_expr + n t + + let pr_raw_tactic = pr_raw_tactic_level ltop + + let pr_and_constr_expr pr (c,_) = pr c + + let pr_pat_and_constr_expr pr (_,(c,_),_) = pr c + + let pr_glob_tactic_level env n t = + let glob_printers = + (strip_prod_binders_glob_constr) + in + let rec prtac n (t:glob_tactic_expr) = + let pr = { + pr_tactic = prtac; + pr_constr = pr_and_constr_expr (pr_glob_constr_env env); + pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); + pr_lconstr = pr_and_constr_expr (pr_lglob_constr_env env); + pr_pattern = pr_pat_and_constr_expr (pr_glob_constr_env env); + pr_lpattern = pr_pat_and_constr_expr (pr_lglob_constr_env env); + pr_constant = pr_or_var (pr_and_short_name (pr_evaluable_reference_env env)); + pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant); + pr_name = pr_lident; + pr_generic = (fun arg -> Pputils.pr_glb_generic (Global.env ()) arg); + pr_extend = pr_glob_extend_rec + (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) + prtac (pr_pat_and_constr_expr (pr_glob_constr_env env)); + pr_alias = pr_glob_alias + (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) + prtac (pr_pat_and_constr_expr (pr_glob_constr_env env)); + } in + make_pr_tac + pr glob_printers + tag_glob_atomic_tactic_expr tag_glob_tactic_expr + n t + in + prtac n t + + let pr_glob_tactic env = pr_glob_tactic_level env ltop + + let strip_prod_binders_constr n ty = + let rec strip_ty acc n ty = + if n=0 then (List.rev acc, ty) else + match Term.kind_of_term ty with + Term.Prod(na,a,b) -> + strip_ty (([Loc.ghost,na],a)::acc) (n-1) b + | _ -> error "Cannot translate fix tactic: not enough products" in + strip_ty [] n ty + + let pr_atomic_tactic_level env n t = + let prtac n (t:atomic_tactic_expr) = + let pr = { + pr_tactic = (fun _ _ -> str ""); + pr_constr = pr_constr_env env Evd.empty; + pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); + pr_lconstr = pr_lconstr_env env Evd.empty; + pr_pattern = pr_constr_pattern_env env Evd.empty; + pr_lpattern = pr_lconstr_pattern_env env Evd.empty; + pr_constant = pr_evaluable_reference_env env; + pr_reference = pr_located pr_ltac_constant; + pr_name = pr_id; + (** Those are not used by the atomic printer *) + pr_generic = (fun _ -> assert false); + pr_extend = (fun _ _ _ -> assert false); + pr_alias = (fun _ _ _ -> assert false); + } + in + pr_atom pr strip_prod_binders_constr tag_atomic_tactic_expr t + in + prtac n t + + let pr_raw_generic = Pputils.pr_raw_generic + + let pr_glb_generic = Pputils.pr_glb_generic + + let pr_raw_extend env = pr_raw_extend_rec + pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr + + let pr_glob_extend env = pr_glob_extend_rec + (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) + (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env)) + + let pr_alias pr lev key args = + pr_alias_gen (fun _ arg -> pr arg) lev key args + + let pr_extend pr lev ml args = + pr_extend_gen pr lev ml args + + let pr_atomic_tactic env = pr_atomic_tactic_level env ltop + +end + +module Tag = +struct + let keyword = + let style = Terminal.make ~bold:true () in + Ppstyle.make ~style ["tactic"; "keyword"] + + let primitive = + let style = Terminal.make ~fg_color:`LIGHT_GREEN () in + Ppstyle.make ~style ["tactic"; "primitive"] + + let string = + let style = Terminal.make ~fg_color:`LIGHT_RED () in + Ppstyle.make ~style ["tactic"; "string"] + +end + +include Make (Ppconstr) (struct + let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s + let do_not_tag _ x = x + let tag_keyword = tag Tag.keyword + let tag_primitive = tag Tag.primitive + let tag_string = tag Tag.string + let tag_glob_tactic_expr = do_not_tag + let tag_glob_atomic_tactic_expr = do_not_tag + let tag_raw_tactic_expr = do_not_tag + let tag_raw_atomic_tactic_expr = do_not_tag + let tag_atomic_tactic_expr = do_not_tag +end) + +let declare_extra_genarg_pprule wit + (f : 'a raw_extra_genarg_printer) + (g : 'b glob_extra_genarg_printer) + (h : 'c extra_genarg_printer) = + begin match wit with + | ExtraArg s -> () + | _ -> error "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 g x = + 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 + in + let h x = + let env = Global.env () in + h (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) (fun _ _ -> str "") x + in + Genprint.register_print0 wit f g h + +(** Registering *) + +let run_delayed c = + Sigma.run Evd.empty { Sigma.run = fun sigma -> c.delayed (Global.env ()) sigma } + +let run_delayed_destruction_arg = function (* HH: Using Evd.empty looks suspicious *) + | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (fst (run_delayed g)) + | clear_flag,ElimOnAnonHyp n as x -> x + | clear_flag,ElimOnIdent id as x -> x + +let () = + let pr_bool b = if b then str "true" else str "false" in + let pr_unit _ = str "()" in + let pr_string s = str "\"" ++ str s ++ str "\"" in + Genprint.register_print0 wit_int_or_var + (pr_or_var int) (pr_or_var int) int; + Genprint.register_print0 wit_ref + pr_reference (pr_or_var (pr_located pr_global)) pr_global; + Genprint.register_print0 wit_ident + pr_id pr_id pr_id; + Genprint.register_print0 wit_var + (pr_located pr_id) (pr_located pr_id) pr_id; + Genprint.register_print0 + wit_intro_pattern + (Miscprint.pr_intro_pattern pr_constr_expr) + (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr c)) + (Miscprint.pr_intro_pattern (fun c -> pr_constr (fst (run_delayed c)))); + Genprint.register_print0 + wit_clause_dft_concl + (pr_clauses (Some true) pr_lident) + (pr_clauses (Some true) pr_lident) + (pr_clauses (Some true) (fun id -> pr_lident (Loc.ghost,id))) + ; + Genprint.register_print0 + wit_constr + Ppconstr.pr_constr_expr + (fun (c, _) -> Printer.pr_glob_constr c) + Printer.pr_constr + ; + Genprint.register_print0 + wit_uconstr + Ppconstr.pr_constr_expr + (fun (c,_) -> Printer.pr_glob_constr c) + Printer.pr_closed_glob + ; + Genprint.register_print0 + wit_open_constr + Ppconstr.pr_constr_expr + (fun (c, _) -> Printer.pr_glob_constr c) + Printer.pr_constr + ; + 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, pr_and_constr_expr pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr)) + (pr_red_expr (pr_constr, pr_lconstr, pr_evaluable_reference, pr_constr_pattern)); + Genprint.register_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; + Genprint.register_print0 wit_bindings + (pr_bindings_no_with pr_constr_expr pr_lconstr_expr) + (pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) + (fun it -> pr_bindings_no_with pr_constr pr_lconstr (fst (run_delayed it))); + 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) (pr_and_constr_expr pr_lglob_constr)) + (fun it -> pr_with_bindings pr_constr pr_lconstr (fst (run_delayed it))); + 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) (pr_and_constr_expr pr_lglob_constr)) + (fun it -> pr_destruction_arg pr_constr pr_lconstr (run_delayed_destruction_arg it)); + Genprint.register_print0 Stdarg.wit_int int int int; + Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool pr_bool; + Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit pr_unit; + Genprint.register_print0 Stdarg.wit_pre_ident str str str; + Genprint.register_print0 Stdarg.wit_string pr_string pr_string pr_string + +let () = + let printer _ _ prtac = prtac (0, E) in + declare_extra_genarg_pprule wit_tactic printer printer printer + +let () = + let pr_unit _ _ _ () = str "()" in + let printer _ _ prtac = prtac (0, E) in + declare_extra_genarg_pprule wit_ltac printer printer pr_unit + +module Richpp = struct + + include Make (Ppconstr.Richpp) (struct + open Ppannotation + open Genarg + let do_not_tag _ x = x + let tag e s = Pp.tag (Pp.Tag.inj e tag) s + let tag_keyword = tag AKeyword + let tag_primitive = tag AKeyword + let tag_string = do_not_tag () + let tag_glob_tactic_expr e = tag (AGlbGenArg (in_gen (glbwit wit_ltac) e)) + let tag_glob_atomic_tactic_expr = do_not_tag + let tag_raw_tactic_expr e = tag (ARawGenArg (in_gen (rawwit wit_ltac) e)) + let tag_raw_atomic_tactic_expr = do_not_tag + let tag_atomic_tactic_expr = do_not_tag + end) + +end diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli new file mode 100644 index 000000000..86e3ea548 --- /dev/null +++ b/plugins/ltac/pptactic.mli @@ -0,0 +1,67 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* std_ppcmds) -> + (constr_expr -> std_ppcmds) -> + (tolerability -> raw_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +type 'a glob_extra_genarg_printer = + (glob_constr_and_expr -> std_ppcmds) -> + (glob_constr_and_expr -> std_ppcmds) -> + (tolerability -> glob_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +type 'a extra_genarg_printer = + (Term.constr -> std_ppcmds) -> + (Term.constr -> std_ppcmds) -> + (tolerability -> Val.t -> std_ppcmds) -> + 'a -> std_ppcmds + +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 + +type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list + +type pp_tactic = { + pptac_level : int; + pptac_prods : grammar_terminals; +} + +val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit + +(** The default pretty-printers produce {!Pp.std_ppcmds} that are + interpreted as raw strings. *) +include Pptacticsig.Pp + +(** The rich pretty-printers produce {!Pp.std_ppcmds} that are + interpreted as annotated strings. The annotations can be + retrieved using {!RichPp.rich_pp}. Their definitions are + located in {!Ppannotation.t}. *) +module Richpp : Pptacticsig.Pp + +val ltop : tolerability diff --git a/plugins/ltac/pptacticsig.mli b/plugins/ltac/pptacticsig.mli new file mode 100644 index 000000000..74ddd377a --- /dev/null +++ b/plugins/ltac/pptacticsig.mli @@ -0,0 +1,81 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds + val pr_red_expr : + ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> + ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds + val pr_may_eval : + ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> + ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds + + val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds + + val pr_in_clause : + ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds + + val pr_clauses : bool option -> + ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds + + val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds + + val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds + + val pr_raw_extend: env -> int -> + ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds + + val pr_glob_extend: env -> int -> + ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds + + val pr_extend : + (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds + + val pr_alias_key : Names.KerName.t -> std_ppcmds + + val pr_alias : (Val.t -> std_ppcmds) -> + int -> Names.KerName.t -> Val.t list -> std_ppcmds + + val pr_alias_key : Names.KerName.t -> std_ppcmds + + val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds + + val pr_raw_tactic : raw_tactic_expr -> std_ppcmds + + val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds + + val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds + + val pr_atomic_tactic : env -> atomic_tactic_expr -> std_ppcmds + + val pr_hintbases : string list option -> std_ppcmds + + val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds + + val pr_bindings : + ('constr -> std_ppcmds) -> + ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds + + val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds + + val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> + ('b, 'a) match_rule -> std_ppcmds + + val pr_value : tolerability -> Val.t -> std_ppcmds + +end diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml new file mode 100644 index 000000000..2514ededb --- /dev/null +++ b/plugins/ltac/profile_ltac.ml @@ -0,0 +1,420 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* strbrk "Ltac Profiler cannot yet handle backtracking \ + into multi-success tactics; profiling results may be wildly inaccurate.") + +let warn_encountered_multi_success_backtracking () = + if !encountered_multi_success_backtracking then + warn_profile_backtracking () + +let encounter_multi_success_backtracking () = + if not !encountered_multi_success_backtracking + then begin + encountered_multi_success_backtracking := true; + warn_encountered_multi_success_backtracking () + end + + +(* *************** tree data structure for profiling ****************** *) + +type treenode = { + name : M.key; + total : float; + local : float; + ncalls : int; + max_total : float; + children : treenode M.t +} + +let empty_treenode name = { + name; + total = 0.0; + local = 0.0; + ncalls = 0; + max_total = 0.0; + children = M.empty; +} + +let root = "root" + +module Local = Summary.Local + +let stack = Local.ref ~name:"LtacProf-stack" [empty_treenode root] + +let reset_profile_tmp () = + Local.(stack := [empty_treenode root]); + encountered_multi_success_backtracking := false + +(* ************** XML Serialization ********************* *) + +let rec of_ltacprof_tactic (name, t) = + assert (String.equal name t.name); + let open Xml_datatype in + let total = string_of_float t.total in + let local = string_of_float t.local in + let ncalls = string_of_int t.ncalls in + let max_total = string_of_float t.max_total in + let children = List.map of_ltacprof_tactic (M.bindings t.children) in + Element ("ltacprof_tactic", + [ ("name", name); ("total",total); ("local",local); + ("ncalls",ncalls); ("max_total",max_total)], + children) + +let of_ltacprof_results t = + let open Xml_datatype in + assert(String.equal t.name root); + let children = List.map of_ltacprof_tactic (M.bindings t.children) in + Element ("ltacprof", [("total_time", string_of_float t.total)], children) + +let rec to_ltacprof_tactic m xml = + let open Xml_datatype in + match xml with + | Element ("ltacprof_tactic", + [("name", name); ("total",total); ("local",local); + ("ncalls",ncalls); ("max_total",max_total)], xs) -> + let node = { + name; + total = float_of_string total; + local = float_of_string local; + ncalls = int_of_string ncalls; + max_total = float_of_string max_total; + children = List.fold_left to_ltacprof_tactic M.empty xs; + } in + M.add name node m + | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof_tactic XML") + +let to_ltacprof_results xml = + let open Xml_datatype in + match xml with + | Element ("ltacprof", [("total_time", t)], xs) -> + { name = root; + total = float_of_string t; + ncalls = 0; + max_total = 0.0; + local = 0.0; + children = List.fold_left to_ltacprof_tactic M.empty xs } + | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof XML") + +let feedback_results results = + Feedback.(feedback + (Custom (Loc.dummy_loc, "ltacprof_results", of_ltacprof_results results))) + +(* ************** pretty printing ************************************* *) + +let format_sec x = (Printf.sprintf "%.3fs" x) +let format_ratio x = (Printf.sprintf "%.1f%%" (100. *. x)) +let padl n s = ws (max 0 (n - utf8_length s)) ++ str s +let padr n s = str s ++ ws (max 0 (n - utf8_length s)) +let padr_with c n s = + let ulength = utf8_length s in + str (utf8_sub s 0 n) ++ str (String.make (max 0 (n - ulength)) c) + +let rec list_iter_is_last f = function + | [] -> [] + | [x] -> [f true x] + | x :: xs -> f false x :: list_iter_is_last f xs + +let header = + str " tactic local total calls max " ++ + fnl () ++ + str "────────────────────────────────────────┴──────┴──────┴───────┴─────────┘" ++ + fnl () + +let rec print_node ~filter all_total indent prefix (s, e) = + h 0 ( + padr_with '-' 40 (prefix ^ s ^ " ") + ++ padl 7 (format_ratio (e.local /. all_total)) + ++ padl 7 (format_ratio (e.total /. all_total)) + ++ padl 8 (string_of_int e.ncalls) + ++ padl 10 (format_sec (e.max_total)) + ) ++ + fnl () ++ + print_table ~filter all_total indent false e.children + +and print_table ~filter all_total indent first_level table = + let fold _ n l = + let s, total = n.name, n.total in + if filter s total then (s, n) :: l else l in + let ls = M.fold fold table [] in + match ls with + | [s, n] when not first_level -> + v 0 (print_node ~filter all_total indent (indent ^ "└") (s, n)) + | _ -> + let ls = + List.sort (fun (_, { total = s1 }) (_, { total = s2}) -> + compare s2 s1) ls in + let iter is_last = + let sep0 = if first_level then "" else if is_last then " " else " │" in + let sep1 = if first_level then "─" else if is_last then " └─" else " ├─" in + print_node ~filter all_total (indent ^ sep0) (indent ^ sep1) + in + prlist (fun pr -> pr) (list_iter_is_last iter ls) + +let to_string ~filter ?(cutoff=0.0) node = + let tree = node.children in + let all_total = M.fold (fun _ { total } a -> total +. a) node.children 0.0 in + let flat_tree = + let global = ref M.empty in + let find_tactic tname l = + try M.find tname !global + with Not_found -> + let e = empty_treenode tname in + global := M.add tname e !global; + e in + let add_tactic tname stats = global := M.add tname stats !global in + let sum_stats add_total + { name; total = t1; local = l1; ncalls = n1; max_total = m1 } + { total = t2; local = l2; ncalls = n2; max_total = m2 } = { + name; + total = if add_total then t1 +. t2 else t1; + local = l1 +. l2; + ncalls = n1 + n2; + max_total = if add_total then max m1 m2 else m1; + children = M.empty; + } in + let rec cumulate table = + let iter _ ({ name; children } as statistics) = + if filter name then begin + let stats' = find_tactic name global in + add_tactic name (sum_stats true stats' statistics); + end; + cumulate children + in + M.iter iter table + in + cumulate tree; + !global + in + warn_encountered_multi_success_backtracking (); + let filter s n = filter s && (all_total <= 0.0 || n /. all_total >= cutoff /. 100.0) in + let msg = + h 0 (str "total time: " ++ padl 11 (format_sec (all_total))) ++ + fnl () ++ + fnl () ++ + header ++ + print_table ~filter all_total "" true flat_tree ++ + fnl () ++ + header ++ + print_table ~filter all_total "" true tree + in + msg + +(* ******************** profiling code ************************************** *) + +let get_child name node = + try M.find name node.children + with Not_found -> empty_treenode name + +let time () = + let times = Unix.times () in + times.Unix.tms_utime +. times.Unix.tms_stime + +let string_of_call ck = + let s = + string_of_ppcmds + (match ck with + | Tacexpr.LtacNotationCall s -> Pptactic.pr_alias_key s + | Tacexpr.LtacNameCall cst -> Pptactic.pr_ltac_constant cst + | Tacexpr.LtacVarCall (id, t) -> Nameops.pr_id id + | Tacexpr.LtacAtomCall te -> + (Pptactic.pr_glob_tactic (Global.env ()) + (Tacexpr.TacAtom (Loc.ghost, te))) + | Tacexpr.LtacConstrInterp (c, _) -> + pr_glob_constr_env (Global.env ()) c + | Tacexpr.LtacMLCall te -> + (Pptactic.pr_glob_tactic (Global.env ()) + te) + ) in + for i = 0 to String.length s - 1 do if s.[i] = '\n' then s.[i] <- ' ' done; + let s = try String.sub s 0 (CString.string_index_from s 0 "(*") with Not_found -> s in + CString.strip s + +let rec merge_sub_tree name tree acc = + try + let t = M.find name acc in + let t = { + name; + total = t.total +. tree.total; + ncalls = t.ncalls + tree.ncalls; + local = t.local +. tree.local; + max_total = max t.max_total tree.max_total; + children = M.fold merge_sub_tree tree.children t.children; + } in + M.add name t acc + with Not_found -> M.add name tree acc + +let merge_roots ?(disjoint=true) t1 t2 = + assert(String.equal t1.name t2.name); + { name = t1.name; + ncalls = t1.ncalls + t2.ncalls; + local = if disjoint then t1.local +. t2.local else t1.local; + total = if disjoint then t1.total +. t2.total else t1.total; + max_total = if disjoint then max t1.max_total t2.max_total else t1.max_total; + children = + M.fold merge_sub_tree t2.children t1.children } + +let rec find_in_stack what acc = function + | [] -> None + | { 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 diff = time () -. start_time in + match Local.(!stack) with + | [] | [_] -> + (* oops, our stack is invalid *) + encounter_multi_success_backtracking (); + reset_profile_tmp () + | node :: (parent :: rest as full_stack) -> + let name = string_of_call c in + if not (String.equal name node.name) then + (* oops, our stack is invalid *) + encounter_multi_success_backtracking (); + let node = { node with + total = node.total +. diff; + local = node.local +. diff; + ncalls = node.ncalls + 1; + max_total = max node.max_total diff; + } in + (* updating the stack *) + let parent = + match find_in_stack node.name [] full_stack with + | None -> + (* no rec-call, we graft the subtree *) + let parent = { parent with + local = parent.local -. diff; + children = M.add node.name node parent.children } in + Local.(stack := parent :: rest); + parent + | Some(to_update, self, rest) -> + (* we coalesce the rec-call and update the lower stack *) + let self = merge_roots ~disjoint:false self node in + let updated_stack = + List.fold_left (fun s x -> + (try M.find x.name (List.hd s).children + with Not_found -> x) :: s) (self :: rest) to_update in + Local.(stack := updated_stack); + List.hd Local.(!stack) + in + (* Calls are over, we reset the stack and send back data *) + if rest == [] && get_profiling () then begin + assert(String.equal root parent.name); + reset_profile_tmp (); + feedback_results parent + end + +let tclFINALLY tac (finally : unit Proofview.tactic) = + let open Proofview.Notations in + Proofview.tclIFCATCH + tac + (fun v -> finally <*> Proofview.tclUNIT v) + (fun (exn, info) -> finally <*> Proofview.tclZERO ~info exn) + +let do_profile s call_trace tac = + let open Proofview.Notations in + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> + if !is_profiling then + match call_trace, Local.(!stack) with + | (_, c) :: _, parent :: rest -> + let name = string_of_call c in + let node = get_child name parent in + Local.(stack := node :: parent :: rest); + Some (time ()) + | _ :: _, [] -> assert false + | _ -> None + else None)) >>= function + | Some start_time -> + tclFINALLY + tac + (Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> + (match call_trace with + | (_, c) :: _ -> exit_tactic start_time c + | [] -> ())))) + | None -> tac + +(* ************** Accumulation of data from workers ************************* *) + +let get_local_profiling_results () = List.hd Local.(!stack) + +module SM = Map.Make(Stateid.Self) + +let data = ref SM.empty + +let _ = + Feedback.(add_feeder (function + | { id = State s; contents = Custom (_, "ltacprof_results", xml) } -> + let results = to_ltacprof_results xml in + let other_results = (* Multi success can cause this *) + try SM.find s !data + with Not_found -> empty_treenode root in + data := SM.add s (merge_roots results other_results) !data + | _ -> ())) + +let reset_profile () = + reset_profile_tmp (); + data := SM.empty + +(* ******************** *) + +let print_results_filter ~cutoff ~filter = + let valid id _ = Stm.state_of_id id <> `Expired in + data := SM.filter valid !data; + 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) +;; + +let print_results ~cutoff = + print_results_filter ~cutoff ~filter:(fun _ -> true) + +let print_results_tactic tactic = + print_results_filter ~cutoff:!Flags.profile_ltac_cutoff ~filter:(fun s -> + String.(equal tactic (sub (s ^ ".") 0 (min (1+length s) (length tactic))))) + +let do_print_results_at_close () = + if get_profiling () then print_results ~cutoff:!Flags.profile_ltac_cutoff + +let _ = Declaremods.append_end_library_hook do_print_results_at_close + +let _ = + let open Goptions in + declare_bool_option + { optsync = true; + optdepr = false; + optname = "Ltac Profiling"; + optkey = ["Ltac"; "Profiling"]; + optread = get_profiling; + optwrite = set_profiling } diff --git a/plugins/ltac/profile_ltac.mli b/plugins/ltac/profile_ltac.mli new file mode 100644 index 000000000..e5e2e4197 --- /dev/null +++ b/plugins/ltac/profile_ltac.mli @@ -0,0 +1,48 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ('a * Tacexpr.ltac_call_kind) list -> + 'b Proofview.tactic -> 'b Proofview.tactic + +val set_profiling : bool -> unit + +(* Cut off results < than specified cutoff *) +val print_results : cutoff:float -> unit + +val print_results_tactic : string -> unit + +val reset_profile : unit -> unit + +val do_print_results_at_close : unit -> unit + +(* The collected statistics for a tactic. The timing data is collected over all + * instances of a given tactic from its parent. E.g. if tactic 'aaa' calls + * 'foo' twice, then 'aaa' will contain just one entry for 'foo' with the + * statistics of the two invocations combined, and also combined over all + * invocations of 'aaa'. + * total: time spent running this tactic and its subtactics (seconds) + * local: time spent running this tactic, minus its subtactics (seconds) + * ncalls: the number of invocations of this tactic that have been made + * max_total: the greatest running time of a single invocation (seconds) + *) +type treenode = { + name : CString.Map.key; + total : float; + local : float; + ncalls : int; + max_total : float; + children : treenode CString.Map.t +} + +(* 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 new file mode 100644 index 000000000..8cb76d81c --- /dev/null +++ b/plugins/ltac/profile_ltac_tactics.ml4 @@ -0,0 +1,40 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* set_profiling b)) + +TACTIC EXTEND start_ltac_profiling +| [ "start" "ltac" "profiling" ] -> [ tclSET_PROFILING true ] +END + +TACTIC EXTEND stop_profiling +| [ "stop" "ltac" "profiling" ] -> [ tclSET_PROFILING false ] +END + +VERNAC COMMAND EXTEND ResetLtacProfiling CLASSIFIED AS SIDEFF + [ "Reset" "Ltac" "Profile" ] -> [ reset_profile() ] +END + +VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY +| [ "Show" "Ltac" "Profile" ] -> [ print_results ~cutoff:!Flags.profile_ltac_cutoff ] +| [ "Show" "Ltac" "Profile" "CutOff" int(n) ] -> [ print_results ~cutoff:(float_of_int n) ] +END + +VERNAC COMMAND EXTEND ShowLtacProfileTactic CLASSIFIED AS QUERY + [ "Show" "Ltac" "Profile" string(s) ] -> [ print_results_tactic s ] +END diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml new file mode 100644 index 000000000..3c5a109c0 --- /dev/null +++ b/plugins/ltac/rewrite.ml @@ -0,0 +1,2223 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + anomaly (str "Global reference " ++ str s ++ str " not found in generalized rewriting") + +let find_reference dir s = + let gr = lazy (try_find_global_reference dir s) in + fun () -> Lazy.force gr + +type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) + +let find_global dir s = + let gr = lazy (try_find_global_reference dir s) in + fun (evd,cstrs) -> + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force gr) in + let evd = Sigma.to_evar_map sigma in + (evd, cstrs), c + +(** Utility for dealing with polymorphic applications *) + +(** Global constants. *) + +let coq_eq_ref = find_reference ["Init"; "Logic"] "eq" +let coq_eq = find_global ["Init"; "Logic"] "eq" +let coq_f_equal = find_global ["Init"; "Logic"] "f_equal" +let coq_all = find_global ["Init"; "Logic"] "all" +let impl = find_global ["Program"; "Basics"] "impl" + +(** Bookkeeping which evars are constraints so that we can + remove them at the end of the tactic. *) + +let goalevars evars = fst evars +let cstrevars evars = snd evars + +let new_cstr_evar (evd,cstrs) env t = + let s = Typeclasses.set_resolvable Evd.Store.empty false in + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (t, evd', _) = Evarutil.new_evar ~store:s env evd t in + let evd' = Sigma.to_evar_map evd' in + let ev, _ = destEvar t in + (evd', Evar.Set.add ev cstrs), t + +(** Building or looking up instances. *) +let e_new_cstr_evar env evars t = + let evd', t = new_cstr_evar !evars env t in evars := evd'; t + +(** Building or looking up instances. *) + +let extends_undefined evars evars' = + let f ev evi found = found || not (Evd.mem evars ev) + in fold_undefined f evars' false + +let app_poly_check env evars f args = + let (evars, cstrs), fc = f evars in + let evdref = ref evars in + let t = Typing.e_solve_evars env evdref (mkApp (fc, args)) in + (!evdref, cstrs), t + +let app_poly_nocheck env evars f args = + let evars, fc = f evars in + evars, mkApp (fc, args) + +let app_poly_sort b = + if b then app_poly_nocheck + else app_poly_check + +let find_class_proof proof_type proof_method env evars carrier relation = + try + let evars, goal = app_poly_check env evars proof_type [| carrier ; relation |] in + let evars', c = Typeclasses.resolve_one_typeclass env (goalevars evars) goal in + if extends_undefined (goalevars evars) evars' then raise Not_found + else app_poly_check env (evars',cstrevars evars) proof_method [| carrier; relation; c |] + with e when Logic.catchable_exception e -> raise Not_found + +(** Utility functions *) + +module GlobalBindings (M : sig + val relation_classes : string list + val morphisms : string list + val relation : string list * string + val app_poly : env -> evars -> (evars -> evars * constr) -> constr array -> evars * constr + val arrow : evars -> evars * constr +end) = struct + open M + open Context.Rel.Declaration + let relation : evars -> evars * constr = find_global (fst relation) (snd relation) + + let reflexive_type = find_global relation_classes "Reflexive" + let reflexive_proof = find_global relation_classes "reflexivity" + + let symmetric_type = find_global relation_classes "Symmetric" + let symmetric_proof = find_global relation_classes "symmetry" + + let transitive_type = find_global relation_classes "Transitive" + let transitive_proof = find_global relation_classes "transitivity" + + let forall_relation = find_global morphisms "forall_relation" + let pointwise_relation = find_global morphisms "pointwise_relation" + + let forall_relation_ref = find_reference morphisms "forall_relation" + let pointwise_relation_ref = find_reference morphisms "pointwise_relation" + + let respectful = find_global morphisms "respectful" + let respectful_ref = find_reference morphisms "respectful" + + let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation" + + let coq_forall = find_global morphisms "forall_def" + + let subrelation = find_global relation_classes "subrelation" + let do_subrelation = find_global morphisms "do_subrelation" + let apply_subrelation = find_global morphisms "apply_subrelation" + + let rewrite_relation_class = find_global relation_classes "RewriteRelation" + + let proper_class = lazy (class_info (try_find_global_reference morphisms "Proper")) + let proper_proxy_class = lazy (class_info (try_find_global_reference morphisms "ProperProxy")) + + let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) + + let proper_type = + let l = lazy (Lazy.force proper_class).cl_impl in + fun (evd,cstrs) -> + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in + let evd = Sigma.to_evar_map sigma in + (evd, cstrs), c + + let proper_proxy_type = + let l = lazy (Lazy.force proper_proxy_class).cl_impl in + fun (evd,cstrs) -> + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in + let evd = Sigma.to_evar_map sigma in + (evd, cstrs), c + + let proper_proof env evars carrier relation x = + let evars, goal = app_poly env evars proper_proxy_type [| carrier ; relation; x |] in + new_cstr_evar evars env goal + + let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env + let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env + let get_transitive_proof env = find_class_proof transitive_type transitive_proof env + + let mk_relation env evd a = + app_poly env evd relation [| a |] + + (** Build an infered signature from constraints on the arguments and expected output + relation *) + + let build_signature evars env m (cstrs : (types * types option) option list) + (finalcstr : (types * types option) option) = + let mk_relty evars newenv ty obj = + match obj with + | None | Some (_, None) -> + let evars, relty = mk_relation env evars ty in + if closed0 ty then + let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in + new_cstr_evar evars env' relty + else new_cstr_evar evars newenv relty + | Some (x, Some rel) -> evars, rel + in + let rec aux env evars ty l = + let t = Reductionops.whd_all env (goalevars evars) ty in + match kind_of_term t, l with + | Prod (na, ty, b), obj :: cstrs -> + let b = Reductionops.nf_betaiota (goalevars evars) b in + if noccurn 1 b (* non-dependent product *) then + let ty = Reductionops.nf_betaiota (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 + evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs + else + let (evars, b, arg, cstrs) = + aux (Environ.push_rel (LocalAssum (na, ty)) env) evars b cstrs + in + let ty = Reductionops.nf_betaiota (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 + if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs + else error "build_signature: no constraint can apply on a dependent argument" + | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products") + | _, [] -> + (match finalcstr with + | None | Some (_, None) -> + let t = Reductionops.nf_betaiota (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]) + in aux env evars m cstrs + + (** Folding/unfolding of the tactic constants. *) + + let unfold_impl t = + match kind_of_term t with + | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> + mkProd (Anonymous, a, lift 1 b) + | _ -> assert false + + let unfold_all t = + match kind_of_term t with + | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> + (match kind_of_term b with + | Lambda (n, ty, b) -> mkProd (n, ty, b) + | _ -> assert false) + | _ -> assert false + + let unfold_forall t = + match kind_of_term t with + | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> + (match kind_of_term b with + | Lambda (n, ty, b) -> mkProd (n, ty, b) + | _ -> assert false) + | _ -> assert false + + let arrow_morphism env evd ta tb a b = + let ap = is_Prop ta and bp = is_Prop tb in + if ap && bp then app_poly env evd impl [| a; b |], unfold_impl + else if ap then (* Domain in Prop, CoDomain in Type *) + (app_poly env evd arrow [| a; b |]), unfold_impl + (* (evd, mkProd (Anonymous, a, b)), (fun x -> x) *) + else if bp then (* Dummy forall *) + (app_poly env evd coq_all [| a; mkLambda (Anonymous, a, lift 1 b) |]), unfold_forall + else (* None in Prop, use arrow *) + (app_poly env evd arrow [| a; b |]), unfold_impl + + let rec decomp_pointwise n c = + if Int.equal n 0 then c + else + match kind_of_term c with + | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f -> + decomp_pointwise (pred n) relb + | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f -> + decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1])) + | _ -> invalid_arg "decomp_pointwise" + + let rec apply_pointwise rel = function + | arg :: args -> + (match kind_of_term rel with + | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f -> + apply_pointwise relb args + | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f -> + apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args + | _ -> invalid_arg "apply_pointwise") + | [] -> rel + + let pointwise_or_dep_relation env evd n t car rel = + if noccurn 1 car && noccurn 1 rel then + app_poly env evd pointwise_relation [| t; lift (-1) car; lift (-1) rel |] + else + app_poly env evd forall_relation + [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |] + + let lift_cstr env evars (args : constr list) c ty cstr = + let start evars env car = + match cstr with + | None | Some (_, None) -> + let evars, rel = mk_relation env evars car in + new_cstr_evar evars env rel + | Some (ty, Some rel) -> evars, rel + in + let rec aux evars env prod n = + if Int.equal n 0 then start evars env prod + else + match kind_of_term (Reduction.whd_all env prod) with + | Prod (na, ty, b) -> + if noccurn 1 b then + let b' = lift (-1) b in + let evars, rb = aux evars env b' (pred n) in + app_poly env evars pointwise_relation [| ty; b'; rb |] + else + let evars, rb = aux evars (Environ.push_rel (LocalAssum (na, ty)) env) b (pred n) in + app_poly env evars forall_relation + [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] + | _ -> raise Not_found + in + let rec find env c ty = function + | [] -> None + | arg :: args -> + try let evars, found = aux evars env ty (succ (List.length args)) in + Some (evars, found, c, ty, arg :: args) + with Not_found -> + let ty = whd_all env ty in + find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args + in find env c ty args + + let unlift_cstr env sigma = function + | None -> None + | Some codom -> Some (decomp_pointwise 1 codom) + + (** Looking up declared rewrite relations (instances of [RewriteRelation]) *) + let is_applied_rewrite_relation env sigma rels t = + match kind_of_term t with + | App (c, args) when Array.length args >= 2 -> + let head = if isApp c then fst (destApp c) else c in + if Globnames.is_global (coq_eq_ref ()) head then None + else + (try + let params, args = Array.chop (Array.length args - 2) args in + let env' = Environ.push_rel_context rels env in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma ((evar, _), evars, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in + let evars = Sigma.to_evar_map evars in + let evars, inst = + app_poly env (evars,Evar.Set.empty) + rewrite_relation_class [| evar; mkApp (c, params) |] in + let _ = Typeclasses.resolve_one_typeclass env' (goalevars evars) inst in + Some (it_mkProd_or_LetIn t rels) + with e when CErrors.noncritical e -> None) + | _ -> None + + +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 type_app_poly env env evd f args = + let evars, c = app_poly_nocheck env evd f args in + let evd', t = Typing.type_of env (goalevars evars) c in + (evd', cstrevars evars), c + +module PropGlobal = struct + module Consts = + struct + let relation_classes = ["Classes"; "RelationClasses"] + let morphisms = ["Classes"; "Morphisms"] + let relation = ["Relations";"Relation_Definitions"], "relation" + let app_poly = app_poly_nocheck + let arrow = find_global ["Program"; "Basics"] "arrow" + let coq_inverse = find_global ["Program"; "Basics"] "flip" + end + + module G = GlobalBindings(Consts) + + include G + include Consts + let inverse env evd car rel = + type_app_poly env env evd coq_inverse [| car ; car; mkProp; rel |] + (* app_poly env evd coq_inverse [| car ; car; mkProp; rel |] *) + +end + +module TypeGlobal = struct + module Consts = + struct + let relation_classes = ["Classes"; "CRelationClasses"] + let morphisms = ["Classes"; "CMorphisms"] + let relation = relation_classes, "crelation" + let app_poly = app_poly_check + let arrow = find_global ["Classes"; "CRelationClasses"] "arrow" + let coq_inverse = find_global ["Classes"; "CRelationClasses"] "flip" + end + + module G = GlobalBindings(Consts) + include G + include Consts + + + let inverse env (evd,cstrs) car rel = + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (sort, sigma, _) = Evarutil.new_Type ~rigid:Evd.univ_flexible env sigma in + let evd = Sigma.to_evar_map sigma in + app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |] + +end + +let sort_of_rel env evm rel = + Reductionops.sort_of_arity env evm (Retyping.get_type_of env evm rel) + +let is_applied_rewrite_relation = PropGlobal.is_applied_rewrite_relation + +(* let _ = *) +(* Hook.set Equality.is_applied_rewrite_relation is_applied_rewrite_relation *) + +let split_head = function + hd :: tl -> hd, tl + | [] -> assert(false) + +let eq_pb (ty, env, x, y as pb) (ty', env', x', y' as pb') = + pb == pb' || (ty == ty' && Constr.equal x x' && Constr.equal y y') + +let problem_inclusion x y = + List.for_all (fun pb -> List.exists (fun pb' -> eq_pb pb pb') y) x + +let evd_convertible env evd x y = + try + (* Unfortunately, the_conv_x might say they are unifiable even if some + unsolvable constraints remain, so we check that this unification + does not introduce any new problem. *) + let _, pbs = Evd.extract_all_conv_pbs evd in + let evd' = Evarconv.the_conv_x env x y evd in + let _, pbs' = Evd.extract_all_conv_pbs evd' in + if evd' == evd || problem_inclusion pbs' pbs then Some evd' + else None + with e when CErrors.noncritical e -> None + +let convertible env evd x y = + Reductionops.is_conv_leq env evd x y + +type hypinfo = { + prf : constr; + car : constr; + rel : constr; + sort : bool; (* true = Prop; false = Type *) + c1 : constr; + c2 : constr; + holes : Clenv.hole list; +} + +let get_symmetric_proof b = + if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof + +let error_no_relation () = error "Cannot find a relation to rewrite." + +let rec decompose_app_rel env evd t = + (** Head normalize for compatibility with the old meta mechanism *) + let t = Reductionops.whd_betaiota evd t in + match kind_of_term t with + | App (f, [||]) -> assert false + | App (f, [|arg|]) -> + let (f', argl, argr) = decompose_app_rel env evd arg in + let ty = Typing.unsafe_type_of env evd argl in + let f'' = mkLambda (Name default_dependent_ident, ty, + mkLambda (Name (Id.of_string "y"), lift 1 ty, + mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |]))) + in (f'', argl, argr) + | App (f, args) -> + let len = Array.length args in + let fargs = Array.sub args 0 (Array.length args - 2) in + let rel = mkApp (f, fargs) in + rel, args.(len - 2), args.(len - 1) + | _ -> error_no_relation () + +let decompose_app_rel env evd t = + let (rel, t1, t2) = decompose_app_rel env evd t in + let ty = Retyping.get_type_of env evd rel in + let () = if not (Reduction.is_arity env ty) then error_no_relation () in + (rel, t1, t2) + +let decompose_applied_relation env sigma (c,l) = + let open Context.Rel.Declaration in + let ctype = Retyping.get_type_of env sigma c in + let find_rel ty = + let sigma, cl = Clenv.make_evar_clause env sigma ty in + let sigma = Clenv.solve_evar_clause env sigma true cl l in + let { Clenv.cl_holes = holes; Clenv.cl_concl = t } = cl in + let (equiv, c1, c2) = decompose_app_rel env sigma t in + let ty1 = Retyping.get_type_of env sigma c1 in + let ty2 = Retyping.get_type_of env sigma c2 in + match evd_convertible env sigma ty1 ty2 with + | None -> None + | Some sigma -> + let sort = sort_of_rel env sigma equiv in + let args = Array.map_of_list (fun h -> h.Clenv.hole_evar) holes in + let value = mkApp (c, args) in + Some (sigma, { prf=value; + car=ty1; rel = equiv; sort = Sorts.is_prop sort; + c1=c1; c2=c2; holes }) + in + match find_rel ctype with + | Some c -> c + | None -> + let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) + match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with + | Some c -> c + | None -> error "Cannot find an homogeneous relation to rewrite." + +let rewrite_db = "rewrite" + +let conv_transparent_state = (Id.Pred.empty, Cpred.full) + +let _ = + Hints.add_hints_init + (fun () -> + Hints.create_hint_db false rewrite_db conv_transparent_state true) + +let rewrite_transparent_state () = + Hints.Hint_db.transparent_state (Hints.searchtable_map rewrite_db) + +let rewrite_core_unif_flags = { + Unification.modulo_conv_on_closed_terms = None; + Unification.use_metas_eagerly_in_conv_on_closed_terms = true; + Unification.use_evars_eagerly_in_conv_on_closed_terms = true; + Unification.modulo_delta = empty_transparent_state; + Unification.modulo_delta_types = full_transparent_state; + Unification.check_applied_meta_types = true; + Unification.use_pattern_unification = true; + Unification.use_meta_bound_pattern_unification = true; + Unification.frozen_evars = Evar.Set.empty; + Unification.restrict_conv_on_strict_subterms = false; + Unification.modulo_betaiota = false; + Unification.modulo_eta = true; +} + +(* Flags used for the setoid variant of "rewrite" and for the strategies + "hints"/"old_hints"/"terms" of "rewrite_strat", and for solving pre-existing + evars in "rewrite" (see unify_abs) *) +let rewrite_unif_flags = + let flags = rewrite_core_unif_flags in { + Unification.core_unify_flags = flags; + Unification.merge_unify_flags = flags; + Unification.subterm_unify_flags = flags; + Unification.allow_K_in_toplevel_higher_order_unification = true; + Unification.resolve_evars = true + } + +let rewrite_core_conv_unif_flags = { + rewrite_core_unif_flags with + Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; + Unification.modulo_delta_types = conv_transparent_state; + Unification.modulo_betaiota = true +} + +(* Fallback flags for the setoid variant of "rewrite" *) +let rewrite_conv_unif_flags = + let flags = rewrite_core_conv_unif_flags in { + Unification.core_unify_flags = flags; + Unification.merge_unify_flags = flags; + Unification.subterm_unify_flags = flags; + Unification.allow_K_in_toplevel_higher_order_unification = true; + Unification.resolve_evars = true + } + +(* Flags for "setoid_rewrite c"/"rewrite_strat -> c" *) +let general_rewrite_unif_flags () = + let ts = rewrite_transparent_state () in + let core_flags = + { rewrite_core_unif_flags with + Unification.modulo_conv_on_closed_terms = Some ts; + Unification.use_evars_eagerly_in_conv_on_closed_terms = true; + Unification.modulo_delta = ts; + Unification.modulo_delta_types = full_transparent_state; + Unification.modulo_betaiota = true } + in { + Unification.core_unify_flags = core_flags; + Unification.merge_unify_flags = core_flags; + Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = empty_transparent_state }; + Unification.allow_K_in_toplevel_higher_order_unification = true; + Unification.resolve_evars = true + } + +let refresh_hypinfo env sigma (is, cb) = + let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma cb in + let sigma, hypinfo = decompose_applied_relation env sigma cbl in + let { c1; c2; car; rel; prf; sort; holes } = hypinfo in + sigma, (car, rel, prf, c1, c2, holes, sort) + +(** FIXME: write this in the new monad interface *) +let solve_remaining_by env sigma holes by = + match by with + | None -> sigma + | Some tac -> + let map h = + if h.Clenv.hole_deps then None + else + let (evk, _) = destEvar (h.Clenv.hole_evar) in + Some evk + in + (** Only solve independent holes *) + let indep = List.map_filter map holes in + let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in + let solve_tac = match tac with + | Genarg.GenArg (Genarg.Glbwit tag, tac) -> + Ftactic.run (Geninterp.interp tag ist tac) (fun _ -> Proofview.tclUNIT ()) + in + let solve_tac = tclCOMPLETE solve_tac in + let solve sigma evk = + let evi = + try Some (Evd.find_undefined sigma evk) + with Not_found -> None + in + match evi with + | None -> sigma + (** Evar should not be defined, but just in case *) + | Some evi -> + let env = Environ.reset_with_named_context evi.evar_hyps env in + let ty = evi.evar_concl in + let c, sigma = Pfedit.refine_by_tactic env sigma ty solve_tac in + Evd.define evk c sigma + in + List.fold_left solve sigma indep + +let no_constraints cstrs = + fun ev _ -> not (Evar.Set.mem ev cstrs) + +let all_constraints cstrs = + fun ev _ -> Evar.Set.mem ev cstrs + +let poly_inverse sort = + if sort then PropGlobal.inverse else TypeGlobal.inverse + +type rewrite_proof = + | RewPrf of constr * constr + (** A Relation (R : rew_car -> rew_car -> Prop) and a proof of R rew_from rew_to *) + | RewCast of cast_kind + (** A proof of convertibility (with casts) *) + +type rewrite_result_info = { + rew_car : constr ; + (** A type *) + rew_from : constr ; + (** A term of type rew_car *) + rew_to : constr ; + (** A term of type rew_car *) + rew_prf : rewrite_proof ; + (** A proof of rew_from == rew_to *) + rew_evars : evars; +} + +type rewrite_result = +| Fail +| Identity +| Success of rewrite_result_info + +type 'a strategy_input = { state : 'a ; (* a parameter: for instance, a state *) + env : Environ.env ; + unfresh : Id.t list ; (* Unfresh names *) + term1 : constr ; + ty1 : types ; (* first term and its type (convertible to rew_from) *) + cstr : (bool (* prop *) * constr option) ; + evars : evars } + +type 'a pure_strategy = { strategy : + 'a strategy_input -> + 'a * rewrite_result (* the updated state and the "result" *) } + +type strategy = unit pure_strategy + +let symmetry env sort rew = + let { rew_evars = evars; rew_car = car; } = rew in + let (rew_evars, rew_prf) = match rew.rew_prf with + | RewCast _ -> (rew.rew_evars, rew.rew_prf) + | RewPrf (rel, prf) -> + try + let evars, symprf = get_symmetric_proof sort env evars car rel in + let prf = mkApp (symprf, [| rew.rew_from ; rew.rew_to ; prf |]) in + (evars, RewPrf (rel, prf)) + with Not_found -> + let evars, rel = poly_inverse sort env evars car rel in + (evars, RewPrf (rel, prf)) + in + { rew with rew_from = rew.rew_to; rew_to = rew.rew_from; rew_prf; rew_evars; } + +(* Matching/unifying the rewriting rule against [t] *) +let unify_eqn (car, rel, prf, c1, c2, holes, sort) l2r flags env (sigma, cstrs) by t = + try + let left = if l2r then c1 else c2 in + let sigma = Unification.w_unify ~flags env sigma CONV left t in + let sigma = Typeclasses.resolve_typeclasses ~filter:(no_constraints cstrs) + ~fail:true env sigma in + let evd = solve_remaining_by env sigma holes by in + let nf c = Evarutil.nf_evar evd (Reductionops.nf_meta evd c) in + let c1 = nf c1 and c2 = nf c2 + and rew_car = nf car and rel = nf rel + and prf = nf prf in + let ty1 = Retyping.get_type_of env evd c1 in + let ty2 = Retyping.get_type_of env evd c2 in + let () = if not (convertible env evd ty2 ty1) then raise Reduction.NotConvertible in + let rew_evars = evd, cstrs in + let rew_prf = RewPrf (rel, prf) in + let rew = { rew_evars; rew_prf; rew_car; rew_from = c1; rew_to = c2; } in + let rew = if l2r then rew else symmetry env sort rew in + Some rew + with + | e when Class_tactics.catchable e -> None + | Reduction.NotConvertible -> None + +let unify_abs (car, rel, prf, c1, c2) l2r sort env (sigma, cstrs) t = + try + let left = if l2r then c1 else c2 in + (* The pattern is already instantiated, so the next w_unify is + basically an eq_constr, except when preexisting evars occur in + either the lemma or the goal, in which case the eq_constr also + solved this evars *) + let sigma = Unification.w_unify ~flags:rewrite_unif_flags env sigma CONV left t in + let rew_evars = sigma, cstrs in + let rew_prf = RewPrf (rel, prf) in + let rew = { rew_car = car; rew_from = c1; rew_to = c2; rew_prf; rew_evars; } in + let rew = if l2r then rew else symmetry env sort rew in + Some rew + with + | e when Class_tactics.catchable e -> None + | Reduction.NotConvertible -> None + +type rewrite_flags = { under_lambdas : bool; on_morphisms : bool } + +let default_flags = { under_lambdas = true; on_morphisms = true; } + +let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None + +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) +let make_eq_refl () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) + +let get_rew_prf r = match r.rew_prf with + | RewPrf (rel, prf) -> rel, prf + | RewCast c -> + let rel = mkApp (make_eq (), [| r.rew_car |]) in + rel, mkCast (mkApp (make_eq_refl (), [| r.rew_car; r.rew_from |]), + c, mkApp (rel, [| r.rew_from; r.rew_to |])) + +let poly_subrelation sort = + if sort then PropGlobal.subrelation else TypeGlobal.subrelation + +let resolve_subrelation env avoid car rel sort prf rel' res = + if eq_constr rel rel' then res + else + let evars, app = app_poly_check env res.rew_evars (poly_subrelation sort) [|car; rel; rel'|] in + let evars, subrel = new_cstr_evar evars env app in + let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in + { res with + rew_prf = RewPrf (rel', appsub); + rew_evars = evars } + +let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) evars = + let evars, morph_instance, proj, sigargs, m', args, args' = + let first = match (Array.findi (fun _ b -> not (Option.is_empty b)) args') with + | Some i -> i + | None -> invalid_arg "resolve_morphism" in + let morphargs, morphobjs = Array.chop first args in + let morphargs', morphobjs' = Array.chop first args' in + let appm = mkApp(m, morphargs) in + let appmtype = Typing.unsafe_type_of env (goalevars evars) appm in + let cstrs = List.map + (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) + (Array.to_list morphobjs') + in + (* Desired signature *) + let evars, appmtype', signature, sigargs = + if b then PropGlobal.build_signature evars env appmtype cstrs cstr + else TypeGlobal.build_signature evars env appmtype cstrs cstr + in + (* Actual signature found *) + let cl_args = [| appmtype' ; signature ; appm |] in + let evars, app = app_poly_sort b env evars (if b then PropGlobal.proper_type else TypeGlobal.proper_type) + cl_args in + let env' = + let dosub, appsub = + if b then PropGlobal.do_subrelation, PropGlobal.apply_subrelation + else TypeGlobal.do_subrelation, TypeGlobal.apply_subrelation + in + Environ.push_named + (LocalDef (Id.of_string "do_subrelation", + snd (app_poly_sort b env evars dosub [||]), + snd (app_poly_nocheck env evars appsub [||]))) + env + in + let evars, morph = new_cstr_evar evars env' app in + evars, morph, morph, sigargs, appm, morphobjs, morphobjs' + in + let projargs, subst, evars, respars, typeargs = + Array.fold_left2 + (fun (acc, subst, evars, sigargs, typeargs') x y -> + let (carrier, relation), sigargs = split_head sigargs in + match relation with + | Some relation -> + let carrier = substl subst carrier + and relation = substl subst relation in + (match y with + | None -> + let evars, proof = + (if b then PropGlobal.proper_proof else TypeGlobal.proper_proof) + env evars carrier relation x in + [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' + | Some r -> + [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, + sigargs, r.rew_to :: typeargs') + | None -> + if not (Option.is_empty y) then + error "Cannot rewrite inside dependent arguments of a function"; + x :: acc, x :: subst, evars, sigargs, x :: typeargs') + ([], [], evars, sigargs, []) args args' + in + let proof = applistc proj (List.rev projargs) in + let newt = applistc m' (List.rev typeargs) in + match respars with + [ a, Some r ] -> evars, proof, substl subst a, substl subst r, oldt, fnewt newt + | _ -> assert(false) + +let apply_constraint env avoid car rel prf cstr res = + match snd cstr with + | None -> res + | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res + +let coerce env avoid cstr res = + let rel, prf = get_rew_prf res in + apply_constraint env avoid res.rew_car rel prf cstr res + +let apply_rule unify loccs : int pure_strategy = + let (nowhere_except_in,occs) = convert_occs loccs in + let is_occ occ = + if nowhere_except_in + then List.mem occ occs + else not (List.mem occ occs) + in + { strategy = fun { state = occ ; env ; unfresh ; + term1 = t ; ty1 = ty ; cstr ; evars } -> + let unif = if isEvar t then None else unify env evars t in + match unif with + | None -> (occ, Fail) + | Some rew -> + let occ = succ occ in + if not (is_occ occ) then (occ, Fail) + else if eq_constr t rew.rew_to then (occ, Identity) + else + let res = { rew with rew_car = ty } in + let rel, prf = get_rew_prf res in + let res = Success (apply_constraint env unfresh rew.rew_car rel prf cstr res) in + (occ, res) + } + +let apply_lemma l2r flags oc by loccs : strategy = { strategy = + fun ({ state = () ; env ; term1 = t ; evars = (sigma, cstrs) } as input) -> + let sigma, c = oc sigma in + let sigma, hypinfo = decompose_applied_relation env sigma c in + let { c1; c2; car; rel; prf; sort; holes } = hypinfo in + let rew = (car, rel, prf, c1, c2, holes, sort) in + let evars = (sigma, cstrs) in + let unify env evars t = + let rew = unify_eqn rew l2r flags env evars by t in + match rew with + | None -> None + | Some rew -> Some rew + in + let _, res = (apply_rule unify loccs).strategy { input with + state = 0 ; + evars } in + (), res + } + +let e_app_poly env evars f args = + let evars', c = app_poly_nocheck env !evars f args in + evars := evars'; + c + +let make_leibniz_proof env c ty r = + let evars = ref r.rew_evars in + let prf = + match r.rew_prf with + | RewPrf (rel, prf) -> + let rel = e_app_poly env evars coq_eq [| ty |] in + let prf = + e_app_poly env evars coq_f_equal + [| r.rew_car; ty; + mkLambda (Anonymous, r.rew_car, c); + r.rew_from; r.rew_to; prf |] + in RewPrf (rel, prf) + | RewCast k -> r.rew_prf + in + { rew_car = ty; rew_evars = !evars; + rew_from = subst1 r.rew_from c; rew_to = subst1 r.rew_to c; rew_prf = prf } + +let reset_env env = + let env' = Global.env_of_context (Environ.named_context_val env) in + Environ.push_rel_context (Environ.rel_context env) env' + +let fold_match ?(force=false) env sigma c = + let (ci, p, c, brs) = destCase c in + let cty = Retyping.get_type_of env sigma c in + let dep, pred, exists, (sk,eff) = + let env', ctx, body = + let ctx, pred = decompose_lam_assum p in + let env' = Environ.push_rel_context ctx env in + env', ctx, pred + in + let sortp = Retyping.get_sort_family_of env' sigma body in + let sortc = Retyping.get_sort_family_of env sigma cty in + let dep = not (noccurn 1 body) in + let pred = if dep then p else + it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx) + in + let sk = + if sortp == InProp then + if sortc == InProp then + if dep then case_dep_scheme_kind_from_prop + else case_scheme_kind_from_prop + else ( + if dep + then case_dep_scheme_kind_from_type_in_prop + else case_scheme_kind_from_type) + else ((* sortc <> InProp by typing *) + if dep + then case_dep_scheme_kind_from_type + else case_scheme_kind_from_type) + in + let exists = Ind_tables.check_scheme sk ci.ci_ind in + if exists || force then + dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind + else raise Not_found + in + let app = + let ind, args = Inductive.find_rectype env cty in + let pars, args = List.chop ci.ci_npar args in + let meths = List.map (fun br -> br) (Array.to_list brs) in + applist (mkConst sk, pars @ [pred] @ meths @ args @ [c]) + in + sk, (if exists then env else reset_env env), app, eff + +let unfold_match env sigma sk app = + match kind_of_term app with + | App (f', args) when eq_constant (fst (destConst f')) sk -> + let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in + Reductionops.whd_beta sigma (mkApp (v, args)) + | _ -> app + +let is_rew_cast = function RewCast _ -> true | _ -> false + +let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = + let rec aux { state ; env ; unfresh ; + term1 = t ; ty1 = ty ; cstr = (prop, cstr) ; evars } = + let cstr' = Option.map (fun c -> (ty, Some c)) cstr in + match kind_of_term t with + | App (m, args) -> + let rewrite_args state success = + let state, (args', evars', progress) = + Array.fold_left + (fun (state, (acc, evars, progress)) arg -> + if not (Option.is_empty progress) && not all then + state, (None :: acc, evars, progress) + else + let argty = Retyping.get_type_of env (goalevars evars) arg in + let state, res = s.strategy { state ; env ; + unfresh ; + term1 = arg ; ty1 = argty ; + cstr = (prop,None) ; + evars } in + let res' = + match res with + | Identity -> + let progress = if Option.is_empty progress then Some false else progress in + (None :: acc, evars, progress) + | Success r -> + (Some r :: acc, r.rew_evars, Some true) + | Fail -> (None :: acc, evars, progress) + in state, res') + (state, ([], evars, success)) args + in + let res = + match progress with + | None -> Fail + | Some false -> Identity + | Some true -> + let args' = Array.of_list (List.rev args') in + if Array.exists + (function + | None -> false + | Some r -> not (is_rew_cast r.rew_prf)) args' + then + let evars', prf, car, rel, c1, c2 = + resolve_morphism env unfresh t m args args' (prop, cstr') evars' + in + let res = { rew_car = ty; rew_from = c1; + rew_to = c2; rew_prf = RewPrf (rel, prf); + rew_evars = evars' } + in Success res + else + let args' = Array.map2 + (fun aorig anew -> + match anew with None -> aorig + | Some r -> r.rew_to) args args' + in + let res = { rew_car = ty; rew_from = t; + rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast; + rew_evars = evars' } + in Success res + in state, res + in + if flags.on_morphisms then + let mty = Retyping.get_type_of env (goalevars evars) m in + let evars, cstr', m, mty, argsl, args = + let argsl = Array.to_list args in + let lift = if prop then PropGlobal.lift_cstr else TypeGlobal.lift_cstr in + match lift env evars argsl m mty None with + | Some (evars, cstr', m, mty, args) -> + evars, Some cstr', m, mty, args, Array.of_list args + | None -> evars, None, m, mty, argsl, args + in + let state, m' = s.strategy { state ; env ; unfresh ; + term1 = m ; ty1 = mty ; + cstr = (prop, cstr') ; evars } in + match m' with + | Fail -> rewrite_args state None (* Standard path, try rewrite on arguments *) + | Identity -> rewrite_args state (Some false) + | Success r -> + (* We rewrote the function and get a proof of pointwise rel for the arguments. + We just apply it. *) + let prf = match r.rew_prf with + | RewPrf (rel, prf) -> + let app = if prop then PropGlobal.apply_pointwise + else TypeGlobal.apply_pointwise + in + RewPrf (app rel argsl, mkApp (prf, args)) + | x -> x + in + let res = + { rew_car = Reductionops.hnf_prod_appvect env (goalevars evars) r.rew_car args; + rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); + rew_prf = prf; rew_evars = r.rew_evars } + in + let res = + match prf with + | RewPrf (rel, prf) -> + Success (apply_constraint env unfresh res.rew_car + rel prf (prop,cstr) res) + | _ -> Success res + in state, res + else rewrite_args state None + + | Prod (n, x, b) when noccurn 1 b -> + let b = subst1 mkProp b in + let tx = Retyping.get_type_of env (goalevars evars) x + and tb = Retyping.get_type_of env (goalevars evars) b in + let arr = if prop then PropGlobal.arrow_morphism + else TypeGlobal.arrow_morphism + in + let (evars', mor), unfold = arr env evars tx tb x b in + let state, res = aux { state ; env ; unfresh ; + term1 = mor ; ty1 = ty ; + cstr = (prop,cstr) ; evars = evars' } in + let res = + match res with + | Success r -> Success { r with rew_to = unfold r.rew_to } + | Fail | Identity -> res + in state, res + + (* if x' = None && flags.under_lambdas then *) + (* let lam = mkLambda (n, x, b) in *) + (* let lam', occ = aux env lam occ None in *) + (* let res = *) + (* match lam' with *) + (* | None -> None *) + (* | Some (prf, (car, rel, c1, c2)) -> *) + (* Some (resolve_morphism env sigma t *) + (* ~fnewt:unfold_all *) + (* (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *) + (* cstr evars) *) + (* in res, occ *) + (* else *) + + | Prod (n, dom, codom) -> + let lam = mkLambda (n, dom, codom) in + let (evars', app), unfold = + if eq_constr ty mkProp then + (app_poly_sort prop env evars coq_all [| dom; lam |]), TypeGlobal.unfold_all + else + let forall = if prop then PropGlobal.coq_forall else TypeGlobal.coq_forall in + (app_poly_sort prop env evars forall [| dom; lam |]), TypeGlobal.unfold_forall + in + let state, res = aux { state ; env ; unfresh ; + term1 = app ; ty1 = ty ; + cstr = (prop,cstr) ; evars = evars' } in + let res = + match res with + | Success r -> Success { r with rew_to = unfold r.rew_to } + | Fail | Identity -> res + in state, res + +(* TODO: real rewriting under binders: introduce x x' (H : R x x') and rewrite with + H at any occurrence of x. Ask for (R ==> R') for the lambda. Formalize this. + B. Barras' idea is to have a context of relations, of length 1, with Σ for gluing + dependent relations and using projections to get them out. + *) + (* | Lambda (n, t, b) when flags.under_lambdas -> *) + (* let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in *) + (* let n'' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n' in *) + (* let n''' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n'' in *) + (* let rel = new_cstr_evar cstr env (mkApp (Lazy.force coq_relation, [|t|])) in *) + (* let env' = Environ.push_rel_context [(n'',None,lift 2 rel);(n'',None,lift 1 t);(n', None, t)] env in *) + (* let b' = s env' avoid b (Typing.type_of env' (goalevars evars) (lift 2 b)) (unlift_cstr env (goalevars evars) cstr) evars in *) + (* (match b' with *) + (* | Some (Some r) -> *) + (* let prf = match r.rew_prf with *) + (* | RewPrf (rel, prf) -> *) + (* let rel = pointwise_or_dep_relation n' t r.rew_car rel in *) + (* let prf = mkLambda (n', t, prf) in *) + (* RewPrf (rel, prf) *) + (* | x -> x *) + (* in *) + (* Some (Some { r with *) + (* rew_prf = prf; *) + (* rew_car = mkProd (n, t, r.rew_car); *) + (* rew_from = mkLambda(n, t, r.rew_from); *) + (* rew_to = mkLambda (n, t, r.rew_to) }) *) + (* | _ -> b') *) + + | Lambda (n, t, b) when flags.under_lambdas -> + let n' = name_app (fun id -> Tactics.fresh_id_in_env unfresh id env) n in + let open Context.Rel.Declaration in + let env' = Environ.push_rel (LocalAssum (n', t)) env in + let bty = Retyping.get_type_of env' (goalevars evars) b in + let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in + let state, b' = s.strategy { state ; env = env' ; unfresh ; + term1 = b ; ty1 = bty ; + cstr = (prop, unlift env evars cstr) ; + evars } in + let res = + match b' with + | Success r -> + let r = match r.rew_prf with + | RewPrf (rel, prf) -> + let point = if prop then PropGlobal.pointwise_or_dep_relation else + TypeGlobal.pointwise_or_dep_relation + in + let evars, rel = point env r.rew_evars n' t r.rew_car rel in + let prf = mkLambda (n', t, prf) in + { r with rew_prf = RewPrf (rel, prf); rew_evars = evars } + | x -> r + in + Success { r with + rew_car = mkProd (n, t, r.rew_car); + rew_from = mkLambda(n, t, r.rew_from); + rew_to = mkLambda (n, t, r.rew_to) } + | Fail | Identity -> b' + in state, res + + | Case (ci, p, c, brs) -> + let cty = Retyping.get_type_of env (goalevars evars) c in + let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in + let cstr' = Some eqty in + let state, c' = s.strategy { state ; env ; unfresh ; + term1 = c ; ty1 = cty ; + cstr = (prop, cstr') ; evars = evars' } in + let state, res = + match c' with + | Success r -> + let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in + let res = make_leibniz_proof env case ty r in + state, Success (coerce env unfresh (prop,cstr) res) + | Fail | Identity -> + if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then + let evars', eqty = app_poly_sort prop env evars coq_eq [| ty |] in + let cstr = Some eqty in + let state, found, brs' = Array.fold_left + (fun (state, found, acc) br -> + if not (Option.is_empty found) then + (state, found, fun x -> lift 1 br :: acc x) + else + let state, res = s.strategy { state ; env ; unfresh ; + term1 = br ; ty1 = ty ; + cstr = (prop,cstr) ; evars } in + match res with + | Success r -> (state, Some r, fun x -> mkRel 1 :: acc x) + | Fail | Identity -> (state, None, fun x -> lift 1 br :: acc x)) + (state, None, fun x -> []) brs + in + match found with + | Some r -> + let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' c'))) in + state, Success (make_leibniz_proof env ctxc ty r) + | None -> state, c' + else + match try Some (fold_match env (goalevars evars) t) with Not_found -> None with + | None -> state, c' + | Some (cst, _, t', eff (*FIXME*)) -> + let state, res = aux { state ; env ; unfresh ; + term1 = t' ; ty1 = ty ; + cstr = (prop,cstr) ; evars } in + let res = + match res with + | Success prf -> + Success { prf with + rew_from = t; + rew_to = unfold_match env (goalevars evars) cst prf.rew_to } + | x' -> c' + in state, res + in + let res = + match res with + | Success r -> + let rel, prf = get_rew_prf r in + Success (apply_constraint env unfresh r.rew_car rel prf (prop,cstr) r) + | Fail | Identity -> res + in state, res + | _ -> state, Fail + in { strategy = aux } + +let all_subterms = subterm true default_flags +let one_subterm = subterm false default_flags + +(** Requires transitivity of the rewrite step, if not a reduction. + Not tail-recursive. *) + +let transitivity state env unfresh prop (res : rewrite_result_info) (next : 'a pure_strategy) : + 'a * rewrite_result = + let state, nextres = + next.strategy { state ; env ; unfresh ; + term1 = res.rew_to ; ty1 = res.rew_car ; + cstr = (prop, get_opt_rew_rel res.rew_prf) ; + evars = res.rew_evars } + in + let res = + match nextres with + | Fail -> Fail + | Identity -> Success res + | Success res' -> + match res.rew_prf with + | RewCast c -> Success { res' with rew_from = res.rew_from } + | RewPrf (rew_rel, rew_prf) -> + match res'.rew_prf with + | RewCast _ -> Success { res with rew_to = res'.rew_to } + | RewPrf (res'_rel, res'_prf) -> + let trans = + if prop then PropGlobal.transitive_type + else TypeGlobal.transitive_type + in + let evars, prfty = + app_poly_sort prop env res'.rew_evars trans [| res.rew_car; rew_rel |] + in + let evars, prf = new_cstr_evar evars env prfty in + let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; + rew_prf; res'_prf |]) + in Success { res' with rew_from = res.rew_from; + rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) } + in state, res + +(** Rewriting strategies. + + Inspired by ELAN's rewriting strategies: + http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.21.4049 +*) + +module Strategies = + struct + + let fail : 'a pure_strategy = + { strategy = fun { state } -> state, Fail } + + let id : 'a pure_strategy = + { strategy = fun { state } -> state, Identity } + + let refl : 'a pure_strategy = + { strategy = + fun { state ; env ; + term1 = t ; ty1 = ty ; + cstr = (prop,cstr) ; evars } -> + let evars, rel = match cstr with + | None -> + let mkr = if prop then PropGlobal.mk_relation else TypeGlobal.mk_relation in + let evars, rty = mkr env evars ty in + new_cstr_evar evars env rty + | Some r -> evars, r + in + let evars, proof = + let proxy = + if prop then PropGlobal.proper_proxy_type + else TypeGlobal.proper_proxy_type + in + let evars, mty = app_poly_sort prop env evars proxy [| ty ; rel; t |] in + new_cstr_evar evars env mty + in + let res = Success { rew_car = ty; rew_from = t; rew_to = t; + rew_prf = RewPrf (rel, proof); rew_evars = evars } + in state, res + } + + let progress (s : 'a pure_strategy) : 'a pure_strategy = { strategy = + fun input -> + let state, res = s.strategy input in + match res with + | Fail -> state, Fail + | Identity -> state, Fail + | Success r -> state, Success r + } + + let seq first snd : 'a pure_strategy = { strategy = + fun ({ env ; unfresh ; cstr } as input) -> + let state, res = first.strategy input in + match res with + | Fail -> state, Fail + | Identity -> snd.strategy { input with state } + | Success res -> transitivity state env unfresh (fst cstr) res snd + } + + let choice fst snd : 'a pure_strategy = { strategy = + fun input -> + let state, res = fst.strategy input in + match res with + | Fail -> snd.strategy { input with state } + | Identity | Success _ -> state, res + } + + let try_ str : 'a pure_strategy = choice str id + + let check_interrupt str input = + Control.check_for_interrupt (); + str input + + let fix (f : 'a pure_strategy -> 'a pure_strategy) : 'a pure_strategy = + let rec aux input = (f { strategy = fun input -> check_interrupt aux input }).strategy input in + { strategy = aux } + + let any (s : 'a pure_strategy) : 'a pure_strategy = + fix (fun any -> try_ (seq s any)) + + let repeat (s : 'a pure_strategy) : 'a pure_strategy = + seq s (any s) + + let bu (s : 'a pure_strategy) : 'a pure_strategy = + fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s')) + + let td (s : 'a pure_strategy) : 'a pure_strategy = + fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s')) + + let innermost (s : 'a pure_strategy) : 'a pure_strategy = + fix (fun ins -> choice (one_subterm ins) s) + + let outermost (s : 'a pure_strategy) : 'a pure_strategy = + fix (fun out -> choice s (one_subterm out)) + + let lemmas cs : 'a pure_strategy = + List.fold_left (fun tac (l,l2r,by) -> + choice tac (apply_lemma l2r rewrite_unif_flags l by AllOccurrences)) + fail cs + + let inj_open hint = (); fun sigma -> + let ctx = Evd.evar_universe_context_of hint.Autorewrite.rew_ctx in + let sigma = Evd.merge_universe_context sigma ctx in + (sigma, (hint.Autorewrite.rew_lemma, NoBindings)) + + let old_hints (db : string) : 'a pure_strategy = + let rules = Autorewrite.find_rewrites db in + lemmas + (List.map (fun hint -> (inj_open hint, hint.Autorewrite.rew_l2r, + hint.Autorewrite.rew_tac)) rules) + + let hints (db : string) : 'a pure_strategy = { strategy = + fun ({ term1 = t } as input) -> + let rules = Autorewrite.find_matches db t in + let lemma hint = (inj_open hint, hint.Autorewrite.rew_l2r, + hint.Autorewrite.rew_tac) in + let lems = List.map lemma rules in + (lemmas lems).strategy input + } + + let reduce (r : Redexpr.red_expr) : 'a pure_strategy = { strategy = + fun { state = state ; env = env ; term1 = t ; ty1 = ty ; cstr = cstr ; evars = evars } -> + let rfn, ckind = Redexpr.reduction_of_red_expr env r in + let sigma = Sigma.Unsafe.of_evar_map (goalevars evars) in + let Sigma (t', sigma, _) = rfn.Reductionops.e_redfun env sigma t in + let evars' = Sigma.to_evar_map sigma in + if eq_constr t' t then + state, Identity + else + state, Success { rew_car = ty; rew_from = t; rew_to = t'; + rew_prf = RewCast ckind; + rew_evars = evars', cstrevars evars } + } + + let fold_glob c : 'a pure_strategy = { strategy = + fun { state ; env ; term1 = t ; ty1 = ty ; cstr ; evars } -> +(* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) + let sigma, c = Pretyping.understand_tcc env (goalevars evars) c in + let unfolded = + try Tacred.try_red_product env sigma c + with e when CErrors.noncritical e -> + error "fold: the term is not unfoldable !" + in + try + let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in + let c' = Evarutil.nf_evar sigma c in + state, Success { rew_car = ty; rew_from = t; rew_to = c'; + rew_prf = RewCast DEFAULTcast; + rew_evars = (sigma, snd evars) } + with e when CErrors.noncritical e -> state, Fail + } + + +end + +(** The strategy for a single rewrite, dealing with occurrences. *) + +(** A dummy initial clauseenv to avoid generating initial evars before + even finding a first application of the rewriting lemma, in setoid_rewrite + mode *) + +let rewrite_with l2r flags c occs : strategy = { strategy = + fun ({ state = () } as input) -> + let unify env evars t = + let (sigma, cstrs) = evars in + let (sigma, rew) = refresh_hypinfo env sigma c in + unify_eqn rew l2r flags env (sigma, cstrs) None t + in + let app = apply_rule unify occs in + let strat = + Strategies.fix (fun aux -> + Strategies.choice app (subterm true default_flags aux)) + in + let _, res = strat.strategy { input with state = 0 } in + ((), res) + } + +let apply_strategy (s : strategy) env unfresh concl (prop, cstr) evars = + let ty = Retyping.get_type_of env (goalevars evars) concl in + let _, res = s.strategy { state = () ; env ; unfresh ; + term1 = concl ; ty1 = ty ; + cstr = (prop, Some cstr) ; evars } in + res + +let solve_constraints env (evars,cstrs) = + let filter = all_constraints cstrs in + Typeclasses.resolve_typeclasses env ~filter ~split:false ~fail:true + (Typeclasses.mark_resolvables ~filter evars) + +let nf_zeta = + Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + +exception RewriteFailure of Pp.std_ppcmds + +type result = (evar_map * constr option * types) option option + +let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result = + let evdref = ref sigma in + let sort = Typing.e_sort_of env evdref concl in + let evars = (!evdref, Evar.Set.empty) in + let evars, cstr = + let prop, (evars, arrow) = + if is_prop_sort sort then true, app_poly_sort true env evars impl [||] + else false, app_poly_sort false env evars TypeGlobal.arrow [||] + in + match is_hyp with + | None -> + let evars, t = poly_inverse prop env evars (mkSort sort) arrow in + evars, (prop, t) + | Some _ -> evars, (prop, arrow) + in + let eq = apply_strategy strat env avoid concl cstr evars in + match eq with + | Fail -> None + | Identity -> Some None + | Success res -> + let (_, cstrs) = res.rew_evars in + let evars' = solve_constraints env res.rew_evars in + let newt = Evarutil.nf_evar evars' res.rew_to in + let evars = (* Keep only original evars (potentially instantiated) and goal evars, + the rest has been defined and substituted already. *) + Evar.Set.fold + (fun ev acc -> + if not (Evd.is_defined acc ev) then + user_err ~hdr:"rewrite" + (str "Unsolved constraint remaining: " ++ spc () ++ + Evd.pr_evar_info (Evd.find acc ev)) + else Evd.remove acc ev) + cstrs evars' + in + let res = match res.rew_prf with + | RewCast c -> None + | RewPrf (rel, p) -> + let p = nf_zeta env evars' (Evarutil.nf_evar evars' p) in + let term = + match abs with + | None -> p + | Some (t, ty) -> + let t = Evarutil.nf_evar evars' t in + let ty = Evarutil.nf_evar evars' ty in + mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) + in + let proof = match is_hyp with + | None -> term + | Some id -> mkApp (term, [| mkVar id |]) + in Some proof + in Some (Some (evars, res, newt)) + +(** Insert a declaration after the last declaration it depends on *) +let rec insert_dependent env decl accu hyps = match hyps with +| [] -> List.rev_append accu [decl] +| ndecl :: rem -> + if occur_var_in_decl env (NamedDecl.get_id ndecl) decl then + List.rev_append accu (decl :: hyps) + else + insert_dependent env decl (ndecl :: accu) rem + +let assert_replacing id newt tac = + let prf = Proofview.Goal.nf_enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let ctx = Environ.named_context env in + let after, before = List.split_when (NamedDecl.get_id %> Id.equal id) ctx in + let nc = match before with + | [] -> assert false + | d :: rem -> insert_dependent env (LocalAssum (NamedDecl.get_id d, newt)) [] after @ rem + in + let env' = Environ.reset_with_named_context (val_of_named_context nc) env in + Refine.refine ~unsafe:false { run = begin fun sigma -> + let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma concl in + let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma newt in + let map d = + let n = NamedDecl.get_id d in + if Id.equal n id then ev' else mkVar n + in + let (e, _) = destEvar ev in + Sigma (mkEvar (e, Array.map_of_list map nc), sigma, p +> q) + end } + end } in + Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) + +let newfail n s = + Proofview.tclZERO (Refiner.FailError (n, lazy 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 treat sigma res = + match res with + | None -> newfail 0 (str "Nothing to rewrite") + | Some None -> if progress then newfail 0 (str"Failed to progress") + else Proofview.tclUNIT () + | Some (Some res) -> + let (undef, prf, newt) = res in + let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in + let gls = List.rev (Evd.fold_undefined fold undef []) in + match clause, prf with + | Some id, Some p -> + let tac = tclTHENLIST [ + Refine.refine ~unsafe:false { run = fun h -> Sigma.here p h }; + Proofview.Unsafe.tclNEWGOALS gls; + ] in + Proofview.Unsafe.tclEVARS undef <*> + tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) + | Some id, None -> + Proofview.Unsafe.tclEVARS undef <*> + convert_hyp_no_check (LocalAssum (id, newt)) <*> + beta_hyp id + | None, Some p -> + Proofview.Unsafe.tclEVARS undef <*> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let make = { run = begin fun sigma -> + let Sigma (ev, sigma, q) = Evarutil.new_evar env sigma newt in + Sigma (mkApp (p, [| ev |]), sigma, q) + end } in + Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls + end } + | None, None -> + Proofview.Unsafe.tclEVARS undef <*> + convert_concl_no_check newt DEFAULTcast + in + Proofview.Goal.nf_enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let ty = match clause with + | None -> concl + | Some id -> Environ.named_type id env + in + let env = match clause with + | None -> env + | Some id -> + (** Only consider variables not depending on [id] *) + let ctx = Environ.named_context env in + let filter decl = not (occur_var_in_decl env id decl) in + let nctx = List.filter filter ctx in + Environ.reset_with_named_context (Environ.val_of_named_context nctx) env + in + try + let res = + cl_rewrite_clause_aux ?abs strat env [] sigma ty clause + in + let sigma = match origsigma with None -> sigma | Some sigma -> sigma in + treat sigma res <*> + (** For compatibility *) + beta <*> Proofview.shelve_unifiable + with + | PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) -> + raise (RewriteFailure (Himsg.explain_pretype_error env evd e)) + end } + +let tactic_init_setoid () = + try init_setoid (); Proofview.tclUNIT () + with e when CErrors.noncritical e -> Tacticals.New.tclFAIL 0 (str"Setoid library not loaded") + +let cl_rewrite_clause_strat progress strat clause = + tactic_init_setoid () <*> + (if progress then Proofview.tclPROGRESS else fun x -> x) + (Proofview.tclOR + (cl_rewrite_clause_newtac ~progress strat clause) + (fun (e, info) -> match e with + | RewriteFailure e -> + tclZEROMSG (str"setoid rewrite failed: " ++ e) + | Refiner.FailError (n, pp) -> + tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) + | e -> Proofview.tclZERO ~info e)) + +(** Setoid rewriting when called with "setoid_rewrite" *) +let cl_rewrite_clause l left2right occs clause = + let strat = rewrite_with left2right (general_rewrite_unif_flags ()) l occs in + cl_rewrite_clause_strat true strat clause + +(** Setoid rewriting when called with "rewrite_strat" *) +let cl_rewrite_clause_strat strat clause = + cl_rewrite_clause_strat false strat clause + +let apply_glob_constr c l2r occs = (); fun ({ state = () ; env = env } as input) -> + let c sigma = + let (sigma, c) = Pretyping.understand_tcc env sigma c in + (sigma, (c, NoBindings)) + in + let flags = general_rewrite_unif_flags () in + (apply_lemma l2r flags c None occs).strategy input + +let interp_glob_constr_list env = + let make c = (); fun sigma -> + let sigma, c = Pretyping.understand_tcc env sigma c in + (sigma, (c, NoBindings)) + in + List.map (fun c -> make c, true, None) + +(* Syntax for rewriting with strategies *) + +type unary_strategy = + Subterms | Subterm | Innermost | Outermost + | Bottomup | Topdown | Progress | Try | Any | Repeat + +type binary_strategy = + | Compose | Choice + +type ('constr,'redexpr) strategy_ast = + | StratId | StratFail | StratRefl + | StratUnary of unary_strategy * ('constr,'redexpr) strategy_ast + | StratBinary of binary_strategy + * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast + | StratConstr of 'constr * bool + | StratTerms of 'constr list + | StratHints of bool * string + | StratEval of 'redexpr + | StratFold of 'constr + +let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function + | StratId | StratFail | StratRefl as s -> s + | StratUnary (s, str) -> StratUnary (s, map_strategy f g str) + | StratBinary (s, str, str') -> StratBinary (s, map_strategy f g str, map_strategy f g str') + | StratConstr (c, b) -> StratConstr (f c, b) + | StratTerms l -> StratTerms (List.map f l) + | StratHints (b, id) -> StratHints (b, id) + | StratEval r -> StratEval (g r) + | StratFold c -> StratFold (f c) + +let pr_ustrategy = function +| Subterms -> str "subterms" +| Subterm -> str "subterm" +| Innermost -> str "innermost" +| Outermost -> str "outermost" +| Bottomup -> str "bottomup" +| Topdown -> str "topdown" +| Progress -> str "progress" +| Try -> str "try" +| Any -> str "any" +| Repeat -> str "repeat" + +let paren p = str "(" ++ p ++ str ")" + +let rec pr_strategy prc prr = function +| StratId -> str "id" +| StratFail -> str "fail" +| StratRefl -> str "refl" +| StratUnary (s, str) -> + pr_ustrategy s ++ spc () ++ paren (pr_strategy prc prr str) +| StratBinary (Choice, str1, str2) -> + str "choice" ++ spc () ++ paren (pr_strategy prc prr str1) ++ spc () ++ + paren (pr_strategy prc prr str2) +| StratBinary (Compose, str1, str2) -> + pr_strategy prc prr str1 ++ str ";" ++ spc () ++ pr_strategy prc prr str2 +| StratConstr (c, true) -> prc c +| StratConstr (c, false) -> str "<-" ++ spc () ++ prc c +| StratTerms cl -> str "terms" ++ spc () ++ pr_sequence prc cl +| StratHints (old, id) -> + let cmd = if old then "old_hints" else "hints" in + str cmd ++ spc () ++ str id +| StratEval r -> str "eval" ++ spc () ++ prr r +| StratFold c -> str "fold" ++ spc () ++ prc c + +let rec strategy_of_ast = function + | StratId -> Strategies.id + | StratFail -> Strategies.fail + | StratRefl -> Strategies.refl + | StratUnary (f, s) -> + let s' = strategy_of_ast s in + let f' = match f with + | Subterms -> all_subterms + | Subterm -> one_subterm + | Innermost -> Strategies.innermost + | Outermost -> Strategies.outermost + | Bottomup -> Strategies.bu + | Topdown -> Strategies.td + | Progress -> Strategies.progress + | Try -> Strategies.try_ + | Any -> Strategies.any + | Repeat -> Strategies.repeat + in f' s' + | StratBinary (f, s, t) -> + let s' = strategy_of_ast s in + let t' = strategy_of_ast t in + let f' = match f with + | Compose -> Strategies.seq + | Choice -> Strategies.choice + in f' s' t' + | StratConstr (c, b) -> { strategy = apply_glob_constr (fst c) b AllOccurrences } + | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id + | StratTerms l -> { strategy = + (fun ({ state = () ; env } as input) -> + let l' = interp_glob_constr_list env (List.map fst l) in + (Strategies.lemmas l').strategy input) + } + | StratEval r -> { strategy = + (fun ({ state = () ; env ; evars } as input) -> + let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in + (Strategies.reduce r_interp).strategy { input with + evars = (sigma,cstrevars evars) }) } + | StratFold c -> Strategies.fold_glob (fst c) + + +(* By default the strategy for "rewrite_db" is top-down *) + +let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l) + +let declare_an_instance n s args = + (((Loc.ghost,Name n),None), Explicit, + CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None), + 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 ()) + binders instance (Some (true, CRecord (Loc.ghost,fields))) + ~global ~generalize:false ~refine:false Hints.empty_hint_info + +let declare_instance_refl global binders a aeq n lemma = + let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" + in anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "reflexivity"),lemma)] + +let declare_instance_sym global binders a aeq n lemma = + let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" + in anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "symmetry"),lemma)] + +let declare_instance_trans global binders a aeq n lemma = + let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" + in anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "transitivity"),lemma)] + +let declare_relation ?(binders=[]) a aeq n refl symm trans = + init_setoid (); + let global = not (Locality.make_section_locality (Locality.LocalityFixme.consume ())) in + let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" + in ignore(anew_instance global binders instance []); + match (refl,symm,trans) with + (None, None, None) -> () + | (Some lemma1, None, None) -> + ignore (declare_instance_refl global binders a aeq n lemma1) + | (None, Some lemma2, None) -> + ignore (declare_instance_sym global binders a aeq n lemma2) + | (None, None, Some lemma3) -> + ignore (declare_instance_trans global binders a aeq n lemma3) + | (Some lemma1, Some lemma2, None) -> + ignore (declare_instance_refl global binders a aeq n lemma1); + ignore (declare_instance_sym global binders a aeq n lemma2) + | (Some lemma1, None, Some lemma3) -> + let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in + let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" + in ignore( + anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "PreOrder_Reflexive"), lemma1); + (Ident (Loc.ghost,Id.of_string "PreOrder_Transitive"),lemma3)]) + | (None, Some lemma2, Some lemma3) -> + let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in + let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" + in ignore( + anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "PER_Symmetric"), lemma2); + (Ident (Loc.ghost,Id.of_string "PER_Transitive"),lemma3)]) + | (Some lemma1, Some lemma2, Some lemma3) -> + let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in + let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in + let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" + in ignore( + anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), lemma1); + (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), lemma2); + (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), lemma3)]) + +let cHole = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) + +let proper_projection r ty = + let ctx, inst = decompose_prod_assum ty in + let mor, args = destApp inst in + let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in + let app = mkApp (Lazy.force PropGlobal.proper_proj, + Array.append args [| instarg |]) in + it_mkLambda_or_LetIn app ctx + +let declare_projection n instance_id r = + let poly = Global.is_polymorphic r in + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma,c = Evd.fresh_global env sigma r in + let ty = Retyping.get_type_of env sigma c in + let term = proper_projection c ty in + let sigma, typ = Typing.type_of env sigma term in + let ctx, typ = decompose_prod_assum typ in + let typ = + let n = + let rec aux t = + match kind_of_term t with + | App (f, [| a ; a' ; rel; rel' |]) + when Globnames.is_global (PropGlobal.respectful_ref ()) f -> + succ (aux rel') + | _ -> 0 + in + let init = + match kind_of_term typ with + App (f, args) when Globnames.is_global (PropGlobal.respectful_ref ()) f -> + mkApp (f, fst (Array.chop (Array.length args - 2) args)) + | _ -> typ + in aux init + in + let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ + in it_mkProd_or_LetIn ccl ctx + in + let typ = it_mkProd_or_LetIn typ ctx in + let pl, ctx = Evd.universe_context sigma in + let cst = + Declare.definition_entry ~types:typ ~poly ~univs:ctx term + in + ignore(Declare.declare_constant n + (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) + +let build_morphism_signature env sigma m = + let m,ctx = Constrintern.interp_constr env sigma m in + let sigma = Evd.from_ctx ctx in + let t = Typing.unsafe_type_of env sigma m in + let cstrs = + let rec aux t = + match kind_of_term t with + | Prod (na, a, b) -> + None :: aux b + | _ -> [] + in aux t + in + let evars, t', sig_, cstrs = + PropGlobal.build_signature (sigma, Evar.Set.empty) env t cstrs None in + let evd = ref evars in + let _ = List.iter + (fun (ty, rel) -> + Option.iter (fun rel -> + let default = e_app_poly env evd PropGlobal.default_relation [| ty; rel |] in + ignore(e_new_cstr_evar env evd default)) + rel) + cstrs + in + let morph = e_app_poly env evd PropGlobal.proper_type [| t; sig_; m |] in + let evd = solve_constraints env !evd in + let evd = Evd.nf_constraints evd in + let m = Evarutil.nf_evars_universes evd morph in + Pretyping.check_evars env Evd.empty evd m; + Evd.evar_universe_context evd, m + +let default_morphism sign m = + let env = Global.env () in + let sigma = Evd.from_env env in + let t = Typing.unsafe_type_of env sigma m in + let evars, _, sign, cstrs = + PropGlobal.build_signature (sigma, Evar.Set.empty) env t (fst sign) (snd sign) + in + let evars, morph = app_poly_check env evars PropGlobal.proper_type [| t; sign; m |] in + let evars, mor = resolve_one_typeclass env (goalevars evars) morph in + mor, proper_projection mor morph + +let add_setoid global binders a aeq t n = + init_setoid (); + let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in + let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in + let _lemma_trans = declare_instance_trans global binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" + in ignore( + anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); + (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); + (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) + + +let make_tactic name = + let open Tacexpr in + let loc = Loc.ghost in + let tacpath = Libnames.qualid_of_string name in + let tacname = Qualid (loc, tacpath) in + TacArg (loc, TacCall (loc, tacname, [])) + +let add_morphism_infer glob m n = + init_setoid (); + let poly = Flags.is_universe_polymorphism () in + let instance_id = add_suffix n "_Proper" in + let env = Global.env () in + let evd = Evd.from_env env in + let uctx, instance = build_morphism_signature env evd m in + if Lib.is_modtype () then + let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id + (Entries.ParameterEntry + (None,poly,(instance,Evd.evar_context_universe_context uctx),None), + 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)); + declare_projection n instance_id (ConstRef cst) + else + let kind = Decl_kinds.Global, poly, + Decl_kinds.DefinitionBody Decl_kinds.Instance + in + let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in + let hook _ = function + | Globnames.ConstRef cst -> + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info + glob poly (ConstRef cst)); + declare_projection n instance_id (ConstRef cst) + | _ -> assert false + in + let hook = Lemmas.mk_hook hook in + Flags.silently + (fun () -> + Lemmas.start_proof instance_id kind (Evd.from_ctx uctx) instance hook; + ignore (Pfedit.by (Tacinterp.interp tac))) () + +let add_morphism glob binders m s n = + init_setoid (); + let poly = Flags.is_universe_polymorphism () in + let instance_id = add_suffix n "_Proper" in + let instance = + (((Loc.ghost,Name instance_id),None), Explicit, + CAppExpl (Loc.ghost, + (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), + [cHole; s; m])) + in + let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in + ignore(new_instance ~global:glob poly binders instance + (Some (true, CRecord (Loc.ghost,[]))) + ~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 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]))) + in + List.iter + (fun (_,binding) -> + match binding with + Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) -> + check_freemetas_is_empty rebus freemetas + | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_), + {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) -> + check_freemetas_is_empty rebus1 freemetas1 ; + check_freemetas_is_empty rebus2 freemetas2 + ) metas + +(* Find a subterm which matches the pattern to rewrite for "rewrite" *) +let unification_rewrite l2r c1 c2 sigma prf car rel but env = + let (sigma,c') = + try + (* ~flags:(false,true) to allow to mark occurrences that must not be + rewritten simply by replacing them with let-defined definitions + in the context *) + Unification.w_unify_to_subterm + ~flags:rewrite_unif_flags + env sigma ((if l2r then c1 else c2),but) + with + | ex when Pretype_errors.precatchable_exception ex -> + (* ~flags:(true,true) to make Ring work (since it really + exploits conversion) *) + Unification.w_unify_to_subterm + ~flags:rewrite_conv_unif_flags + env sigma ((if l2r then c1 else c2),but) + in + let nf c = Evarutil.nf_evar sigma c in + 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; + 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 + let abs = prf, prfty in + let prf = mkRel 1 in + let res = (car, rel, prf, c1, c2) in + abs, sigma, res, Sorts.is_prop sort + +let get_hyp gl (c,l) clause l2r = + let evars = Tacmach.New.project gl in + let env = Tacmach.New.pf_env gl in + let sigma, hi = decompose_applied_relation env evars (c,l) in + let but = match clause with + | Some id -> Tacmach.New.pf_get_hyp_typ id gl + | None -> Evarutil.nf_evar evars (Tacmach.New.pf_concl gl) + in + unification_rewrite l2r hi.c1 hi.c2 sigma hi.prf hi.car hi.rel but env + +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 *) + +(** Setoid rewriting when called with "rewrite" *) +let general_s_rewrite cl l2r occs (c,l) ~new_goals = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let abs, evd, res, sort = get_hyp gl (c,l) cl l2r in + let unify env evars t = unify_abs res l2r sort env evars t in + let app = apply_rule unify occs in + let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in + let substrat = Strategies.fix recstrat in + let strat = { strategy = fun ({ state = () } as input) -> + let _, res = substrat.strategy { input with state = 0 } in + (), res + } + in + let origsigma = Tacmach.New.project gl in + tactic_init_setoid () <*> + Proofview.tclOR + (tclPROGRESS + (tclTHEN + (Proofview.Unsafe.tclEVARS evd) + (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl))) + (fun (e, info) -> match e with + | RewriteFailure e -> + tclFAIL 0 (str"setoid rewrite failed: " ++ e) + | e -> Proofview.tclZERO ~info e) + end } + +let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite + +(** [setoid_]{reflexivity,symmetry,transitivity} tactics *) + +let not_declared env ty rel = + tclFAIL 0 + (str" The relation " ++ Printer.pr_constr_env env Evd.empty rel ++ str" is not a declared " ++ + str ty ++ str" relation. Maybe you need to require the Coq.Classes.RelationClasses library") + +let setoid_proof ty fn fallback = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let concl = Proofview.Goal.concl gl in + Proofview.tclORELSE + begin + try + let rel, _, _ = decompose_app_rel env sigma concl in + let (sigma, t) = Typing.type_of env sigma rel in + let car = RelDecl.get_type (List.hd (fst (Reduction.dest_prod env t))) in + (try init_relation_classes () with _ -> raise Not_found); + fn env sigma car rel + with e -> Proofview.tclZERO e + end + begin function + | e -> + Proofview.tclORELSE + fallback + begin function (e', info) -> match e' with + | Hipattern.NoEquationFound -> + begin match e with + | (Not_found, _) -> + let rel, _, _ = decompose_app_rel env sigma concl in + not_declared env ty rel + | (e, info) -> Proofview.tclZERO ~info e + end + | e' -> Proofview.tclZERO ~info e' + end + end + end } + +let tac_open ((evm,_), c) tac = + (tclTHEN (Proofview.Unsafe.tclEVARS evm) (tac c)) + +let poly_proof getp gett env evm car rel = + if Sorts.is_prop (sort_of_rel env evm rel) then + getp env (evm,Evar.Set.empty) car rel + else gett env (evm,Evar.Set.empty) car rel + +let setoid_reflexivity = + setoid_proof "reflexive" + (fun env evm car rel -> + tac_open (poly_proof PropGlobal.get_reflexive_proof + TypeGlobal.get_reflexive_proof + env evm car rel) + (fun c -> tclCOMPLETE (apply c))) + (reflexivity_red true) + +let setoid_symmetry = + setoid_proof "symmetric" + (fun env evm car rel -> + tac_open + (poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof + env evm car rel) + (fun c -> apply c)) + (symmetry_red true) + +let setoid_transitivity c = + setoid_proof "transitive" + (fun env evm car rel -> + tac_open (poly_proof PropGlobal.get_transitive_proof TypeGlobal.get_transitive_proof + env evm car rel) + (fun proof -> match c with + | None -> eapply proof + | Some c -> apply_with_bindings (proof,ImplicitBindings [ c ]))) + (transitivity_red true c) + +let setoid_symmetry_in id = + Proofview.V82.tactic (fun gl -> + let ctype = pf_unsafe_type_of gl (mkVar id) in + let binders,concl = decompose_prod_assum ctype in + let (equiv, args) = decompose_app concl in + let rec split_last_two = function + | [c1;c2] -> [],(c1, c2) + | x::y::z -> let l,res = split_last_two (y::z) in x::l, res + | _ -> error "Cannot find an equivalence relation to rewrite." + in + let others,(c1,c2) = split_last_two args in + let he,c1,c2 = mkApp (equiv, Array.of_list others),c1,c2 in + let new_hyp' = mkApp (he, [| c2 ; c1 |]) in + let new_hyp = it_mkProd_or_LetIn new_hyp' binders in + Proofview.V82.of_tactic + (tclTHENLAST + (Tactics.assert_after_replacing id new_hyp) + (tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ])) + gl) + +let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity +let _ = Hook.set Tactics.setoid_symmetry setoid_symmetry +let _ = Hook.set Tactics.setoid_symmetry_in setoid_symmetry_in +let _ = Hook.set Tactics.setoid_transitivity setoid_transitivity + +let get_lemma_proof f env evm x y = + let (evm, _), c = f env (evm,Evar.Set.empty) x y in + evm, c + +let get_reflexive_proof = + get_lemma_proof PropGlobal.get_reflexive_proof + +let get_symmetric_proof = + get_lemma_proof PropGlobal.get_symmetric_proof + +let get_transitive_proof = + get_lemma_proof PropGlobal.get_transitive_proof + diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli new file mode 100644 index 000000000..35c448351 --- /dev/null +++ b/plugins/ltac/rewrite.mli @@ -0,0 +1,117 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* strategy + +val map_strategy : ('a -> 'b) -> ('c -> 'd) -> + ('a, 'c) strategy_ast -> ('b, 'd) strategy_ast + +val pr_strategy : ('a -> Pp.std_ppcmds) -> ('b -> Pp.std_ppcmds) -> + ('a, 'b) strategy_ast -> Pp.std_ppcmds + +(** Entry point for user-level "rewrite_strat" *) +val cl_rewrite_clause_strat : strategy -> Id.t option -> unit Proofview.tactic + +(** Entry point for user-level "setoid_rewrite" *) +val cl_rewrite_clause : + interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) -> + bool -> Locus.occurrences -> Id.t option -> unit Proofview.tactic + +val is_applied_rewrite_relation : + env -> evar_map -> Context.Rel.t -> constr -> types option + +val declare_relation : + ?binders:local_binder list -> constr_expr -> constr_expr -> Id.t -> + constr_expr option -> constr_expr option -> constr_expr option -> unit + +val add_setoid : + bool -> local_binder list -> constr_expr -> constr_expr -> constr_expr -> + Id.t -> unit + +val add_morphism_infer : bool -> constr_expr -> Id.t -> unit + +val add_morphism : + bool -> local_binder list -> constr_expr -> constr_expr -> Id.t -> unit + +val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr + +val get_symmetric_proof : env -> evar_map -> constr -> constr -> evar_map * constr + +val get_transitive_proof : env -> evar_map -> constr -> constr -> evar_map * constr + +val default_morphism : + (types * constr option) option list * (types * types option) option -> + constr -> constr * constr + +val setoid_symmetry : unit Proofview.tactic + +val setoid_symmetry_in : Id.t -> unit Proofview.tactic + +val setoid_reflexivity : unit Proofview.tactic + +val setoid_transitivity : constr option -> unit Proofview.tactic + + +val apply_strategy : + strategy -> + Environ.env -> + Names.Id.t list -> + Term.constr -> + bool * Term.constr -> + evars -> rewrite_result diff --git a/plugins/ltac/tacarg.ml b/plugins/ltac/tacarg.ml new file mode 100644 index 000000000..42552c484 --- /dev/null +++ b/plugins/ltac/tacarg.ml @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t +| _ -> assert false + +let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> + let Val.Dyn (t, _) = v in + match Val.eq t (val_tag wit) with + | None -> false + | Some Refl -> true + +let prj : type a. a Val.typ -> Val.t -> a option = fun t v -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> None + | Some Refl -> Some x + +let in_gen wit v = Val.Dyn (val_tag wit, v) +let out_gen wit v = match prj (val_tag wit) v with None -> assert false | Some x -> x + +module Value = +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 + else if has_type v (topwit wit_constr_under_binders) then + let vars, c = out_gen (topwit wit_constr_under_binders) v in + match vars with [] -> Some c | _ -> None + else None + +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 + +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 + +let to_list v = prj Val.typ_list v + +let to_option v = prj Val.typ_opt v + +let to_pair v = prj Val.typ_pair v + +end + +let is_variable env id = + Id.List.mem id (Termops.ids_of_named_context (Environ.named_context env)) + +(* Transforms an id into a constr if possible, or fails with Not_found *) +let constr_of_id env id = + Term.mkVar (let _ = Environ.lookup_named id env in 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 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 + | _, IntroNaming (IntroIdentifier id) -> id + | _ -> fail () + else if has_type v (topwit wit_var) then + out_gen (topwit wit_var) v + else match Value.to_constr v with + | None -> fail () + | Some c -> + (* We need it fresh for intro e.g. in "Tac H = clear H; intro H" *) + if isVar c && not (fresh && is_variable env (destVar c)) then + destVar c + else fail () + + +(* Interprets, if possible, a constr to an identifier which may not + be fresh but suitable to be given to the fresh tactic. Works for + vars, constants, inductive, constructors and sorts. *) +let coerce_to_ident_not_fresh g env v = +let id_of_name = function + | Names.Anonymous -> Id.of_string "x" + | Names.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 + | _, IntroNaming (IntroIdentifier id) -> id + | _ -> fail () + else if has_type v (topwit wit_var) then + out_gen (topwit wit_var) v + else + match Value.to_constr v with + | None -> fail () + | Some c -> + match Constr.kind c with + | Var id -> id + | Meta m -> id_of_name (Evd.meta_name g m) + | Evar (kn,_) -> + begin match Evd.evar_ident kn g with + | None -> fail () + | Some id -> id + end + | Const (cst,_) -> Label.to_id (Constant.label cst) + | Construct (cstr,_) -> + let ref = Globnames.ConstructRef cstr in + let basename = Nametab.basename_of_global ref in + basename + | Ind (ind,_) -> + let ref = Globnames.IndRef ind in + let basename = Nametab.basename_of_global ref in + basename + | Sort s -> + begin + match s with + | Prop _ -> Label.to_id (Label.make "Prop") + | Type _ -> Label.to_id (Label.make "Type") + end + | _ -> fail() + + +let coerce_to_intro_pattern env 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 + let id = out_gen (topwit wit_var) v in + IntroNaming (IntroIdentifier id) + else match Value.to_constr v with + | Some c when isVar c -> + (* This happens e.g. in definitions like "Tac H = clear H; intro H" *) + (* but also in "destruct H as (H,H')" *) + IntroNaming (IntroIdentifier (destVar c)) + | _ -> raise (CannotCoerceTo "an introduction pattern") + +let coerce_to_intro_pattern_naming env v = + match coerce_to_intro_pattern env v with + | IntroNaming pat -> pat + | _ -> 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 + | _ -> raise (CannotCoerceTo "a hint base name") + 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 + | _, IntroNaming (IntroIdentifier id) -> + (try ([], constr_of_id env id) with Not_found -> fail ()) + | _ -> fail () + else if has_type v (topwit wit_constr) then + let c = out_gen (topwit wit_constr) v in + ([], c) + else if has_type v (topwit wit_constr_under_binders) then + out_gen (topwit wit_constr_under_binders) v + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + (try [], constr_of_id env id with Not_found -> fail ()) + 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 + raise (CannotCoerceTo "an untyped term") + +let coerce_to_closed_constr env v = + let ids,c = coerce_to_constr env v in + let () = if not (List.is_empty ids) then raise (CannotCoerceTo "a term") in + c + +let coerce_to_evaluable_ref env 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 + | _, IntroNaming (IntroIdentifier id) when is_variable env id -> EvalVarRef id + | _ -> fail () + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + if Id.List.mem id (Termops.ids_of_context env) then EvalVarRef id + else fail () + else if has_type v (topwit wit_ref) then + let open Globnames in + let r = out_gen (topwit wit_ref) v in + match r with + | VarRef var -> EvalVarRef var + | ConstRef c -> EvalConstRef c + | IndRef _ | ConstructRef _ -> fail () + else + match Value.to_constr v with + | Some c when isConst c -> EvalConstRef (Univ.out_punivs (destConst c)) + | Some c when isVar c -> EvalVarRef (destVar c) + | _ -> fail () + in if Tacred.is_evaluable env ev then ev else fail () + +let coerce_to_constr_list env v = + let v = Value.to_list v in + match v with + | Some l -> + let map v = coerce_to_closed_constr env v in + List.map map l + | None -> raise (CannotCoerceTo "a term list") + +let coerce_to_intro_pattern_list loc env v = + match Value.to_list v with + | None -> raise (CannotCoerceTo "an intro pattern list") + | Some l -> + let map v = (loc, coerce_to_intro_pattern env v) in + List.map map l + +let coerce_to_hyp env 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 + | _ -> fail () + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + if is_variable env id then id else fail () + else match Value.to_constr v with + | Some c when isVar c -> destVar c + | _ -> fail () + +let coerce_to_hyp_list env v = + let v = Value.to_list v in + match v with + | Some l -> + let map n = coerce_to_hyp env n in + List.map map l + | None -> raise (CannotCoerceTo "a variable list") + +(* Interprets a qualified name *) +let coerce_to_reference env v = + let v = Value.normalize v in + match Value.to_constr v with + | Some c -> + begin + try Globnames.global_of_constr c + with Not_found -> raise (CannotCoerceTo "a reference") + end + | None -> raise (CannotCoerceTo "a reference") + +(* Quantified named or numbered hypothesis or hypothesis in context *) +(* (as in Inversion) *) +let coerce_to_quantified_hypothesis 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 + | _, IntroNaming (IntroIdentifier id) -> NamedHyp id + | _ -> raise (CannotCoerceTo "a quantified hypothesis") + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + NamedHyp id + else if has_type v (topwit wit_int) then + AnonHyp (out_gen (topwit wit_int) v) + else match Value.to_constr v with + | Some c when isVar c -> NamedHyp (destVar c) + | _ -> raise (CannotCoerceTo "a quantified hypothesis") + +(* Quantified named or numbered hypothesis or hypothesis in context *) +(* (as in Inversion) *) +let coerce_to_decl_or_quant_hyp env v = + let v = Value.normalize v in + if has_type v (topwit wit_int) then + AnonHyp (out_gen (topwit wit_int) v) + else + try coerce_to_quantified_hypothesis v + with CannotCoerceTo _ -> + raise (CannotCoerceTo "a declared or quantified hypothesis") + +let coerce_to_int_or_var_list v = + match Value.to_list v with + | None -> raise (CannotCoerceTo "an int list") + | Some l -> + let map n = ArgArg (coerce_to_int n) in + List.map map l diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli new file mode 100644 index 000000000..0b67f8726 --- /dev/null +++ b/plugins/ltac/taccoerce.mli @@ -0,0 +1,96 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t + (** Eliminated the leading dynamic type casts. *) + + val of_constr : constr -> t + val to_constr : t -> constr option + val of_uconstr : Glob_term.closed_glob_constr -> t + val to_uconstr : t -> Glob_term.closed_glob_constr option + val of_int : int -> t + val to_int : t -> int option + val to_list : t -> t list option + val to_option : t -> t option option + val to_pair : t -> (t * t) option +end + +(** {5 Coercion functions} *) + +val coerce_to_constr_context : Value.t -> constr + +val coerce_var_to_ident : bool -> Environ.env -> Value.t -> Id.t + +val coerce_to_ident_not_fresh : Evd.evar_map -> Environ.env -> Value.t -> Id.t + +val coerce_to_intro_pattern : Environ.env -> Value.t -> Tacexpr.delayed_open_constr intro_pattern_expr + +val coerce_to_intro_pattern_naming : + Environ.env -> Value.t -> intro_pattern_naming_expr + +val coerce_to_hint_base : Value.t -> string + +val coerce_to_int : Value.t -> int + +val coerce_to_constr : Environ.env -> Value.t -> constr_under_binders + +val coerce_to_uconstr : Environ.env -> Value.t -> Glob_term.closed_glob_constr + +val coerce_to_closed_constr : Environ.env -> Value.t -> constr + +val coerce_to_evaluable_ref : + Environ.env -> Value.t -> evaluable_global_reference + +val coerce_to_constr_list : Environ.env -> Value.t -> constr list + +val coerce_to_intro_pattern_list : + Loc.t -> Environ.env -> Value.t -> Tacexpr.intro_patterns + +val coerce_to_hyp : Environ.env -> Value.t -> Id.t + +val coerce_to_hyp_list : Environ.env -> Value.t -> Id.t list + +val coerce_to_reference : Environ.env -> Value.t -> Globnames.global_reference + +val coerce_to_quantified_hypothesis : Value.t -> quantified_hypothesis + +val coerce_to_decl_or_quant_hyp : Environ.env -> Value.t -> quantified_hypothesis + +val coerce_to_int_or_var_list : Value.t -> int or_var list + +(** {5 Missing generic arguments} *) + +val wit_constr_context : (Empty.t, Empty.t, constr) genarg_type + +val wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) genarg_type diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml new file mode 100644 index 000000000..2e2b55be7 --- /dev/null +++ b/plugins/ltac/tacentries.ml @@ -0,0 +1,525 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* entry_name + +(** Quite ad-hoc *) +let get_tacentry n m = + let check_lvl n = + Int.equal m n + && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) + && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) + in + if check_lvl n then EntryName (rawwit Tacarg.wit_tactic, Aself) + else if check_lvl (n + 1) then EntryName (rawwit Tacarg.wit_tactic, Anext) + else EntryName (rawwit Tacarg.wit_tactic, atactic n) + +let get_separator = function +| None -> error "Missing separator." +| Some sep -> sep + +let rec parse_user_entry s sep = + let l = String.length s in + if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then + let entry = parse_user_entry (String.sub s 3 (l-8)) None in + Ulist1 entry + else if l > 12 && coincide s "ne_" 0 && + coincide s "_list_sep" (l-9) then + let entry = parse_user_entry (String.sub s 3 (l-12)) None in + Ulist1sep (entry, get_separator sep) + else if l > 5 && coincide s "_list" (l-5) then + let entry = parse_user_entry (String.sub s 0 (l-5)) None in + Ulist0 entry + else if l > 9 && coincide s "_list_sep" (l-9) then + let entry = parse_user_entry (String.sub s 0 (l-9)) None in + Ulist0sep (entry, get_separator sep) + else if l > 4 && coincide s "_opt" (l-4) then + let entry = parse_user_entry (String.sub s 0 (l-4)) None in + Uopt entry + else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then + let n = Char.code s.[6] - 48 in + Uentryl ("tactic", n) + else + Uentry s + +let arg_list = function Rawwit t -> Rawwit (ListArg t) +let arg_opt = function Rawwit t -> Rawwit (OptArg t) + +let interp_entry_name interp symb = + let rec eval = function + | Ulist1 e -> Ulist1 (eval e) + | Ulist1sep (e, sep) -> Ulist1sep (eval e, sep) + | Ulist0 e -> Ulist0 (eval e) + | Ulist0sep (e, sep) -> Ulist0sep (eval e, sep) + | Uopt e -> Uopt (eval e) + | Uentry s -> Uentry (interp s None) + | Uentryl (s, n) -> Uentryl (interp s (Some n), n) + in + eval symb + +(**********************************************************************) +(** Grammar declaration for Tactic Notation (Coq level) *) + +let get_tactic_entry n = + if Int.equal n 0 then + Pltac.simple_tactic, None + else if Int.equal n 5 then + Pltac.binder_tactic, None + else if 1<=n && n<5 then + Pltac.tactic_expr, Some (Extend.Level (string_of_int n)) + else + error ("Invalid Tactic Notation level: "^(string_of_int n)^".") + +(**********************************************************************) +(** State of the grammar extensions *) + +type tactic_grammar = { + tacgram_level : int; + tacgram_prods : Pptactic.grammar_terminals; +} + +(* Declaration of the tactic grammar rule *) + +let head_is_ident tg = match tg.tacgram_prods with +| TacTerm _ :: _ -> true +| _ -> false + +let rec prod_item_of_symbol lev = function +| Extend.Ulist1 s -> + let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in + EntryName (Rawwit (ListArg typ), Alist1 e) +| Extend.Ulist0 s -> + let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in + EntryName (Rawwit (ListArg typ), Alist0 e) +| Extend.Ulist1sep (s, sep) -> + let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in + EntryName (Rawwit (ListArg typ), Alist1sep (e, Atoken (CLexer.terminal sep))) +| Extend.Ulist0sep (s, sep) -> + let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in + EntryName (Rawwit (ListArg typ), Alist0sep (e, Atoken (CLexer.terminal sep))) +| Extend.Uopt s -> + let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in + EntryName (Rawwit (OptArg typ), Aopt e) +| Extend.Uentry arg -> + let ArgT.Any tag = arg in + let wit = ExtraArg tag in + EntryName (Rawwit wit, Extend.Aentry (genarg_grammar wit)) +| Extend.Uentryl (s, n) -> + let ArgT.Any tag = s in + assert (coincide (ArgT.repr tag) "tactic" 0); + get_tacentry n lev + +(** Tactic grammar extensions *) + +let add_tactic_entry (kn, ml, tg) state = + let open Tacexpr in + let entry, pos = get_tactic_entry tg.tacgram_level in + let mkact loc l = + let map arg = + (** HACK to handle especially the tactic(...) entry *) + let wit = Genarg.rawwit Tacarg.wit_tactic in + if Genarg.has_type arg wit && not ml then + Tacexp (Genarg.out_gen wit arg) + else + TacGeneric arg + in + let l = List.map map l in + (TacAlias (loc,kn,l):raw_tactic_expr) + in + let () = + if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then + error "Notation for simple tactic must start with an identifier." + in + let map = function + | TacTerm s -> GramTerminal s + | TacNonTerm (loc, s, _) -> + let EntryName (typ, e) = prod_item_of_symbol tg.tacgram_level s in + GramNonTerminal (loc, typ, e) + in + let prods = List.map map tg.tacgram_prods in + let rules = make_rule mkact prods in + let r = ExtendRule (entry, None, (pos, [(None, None, [rules])])) in + ([r], state) + +let tactic_grammar = + create_grammar_command "TacticGrammar" add_tactic_entry + +let extend_tactic_grammar kn ml ntn = extend_grammar_command tactic_grammar (kn, ml, ntn) + +(**********************************************************************) +(* Tactic Notation *) + +let entry_names = ref String.Map.empty + +let register_tactic_notation_entry name entry = + let entry = match entry with + | ExtraArg arg -> ArgT.Any arg + | _ -> assert false + in + entry_names := String.Map.add name entry !entry_names + +let interp_prod_item = function + | TacTerm s -> TacTerm s + | TacNonTerm (loc, (nt, sep), id) -> + let symbol = parse_user_entry nt sep in + let interp s = function + | None -> + if String.Map.mem s !entry_names then String.Map.find s !entry_names + else begin match ArgT.name s with + | None -> error ("Unknown entry "^s^".") + | Some arg -> arg + end + | Some n -> + (** FIXME: do better someday *) + assert (String.equal s "tactic"); + begin match Tacarg.wit_tactic with + | ExtraArg tag -> ArgT.Any tag + | _ -> assert false + end + in + let symbol = interp_entry_name interp symbol in + TacNonTerm (loc, symbol, id) + +let make_fresh_key = + let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in + fun prods -> + let cur = incr id; !id in + let map = function + | TacTerm s -> s + | TacNonTerm _ -> "#" + in + let prods = String.concat "_" (List.map map prods) in + (** We embed the hash of the kernel name in the label so that the identifier + should be mostly unique. This ensures that including two modules + together won't confuse the corresponding labels. *) + let hash = (cur lxor (ModPath.hash (Lib.current_mp ()))) land 0x7FFFFFFF in + let lbl = Id.of_string_soft (Printf.sprintf "%s_%08X" prods hash) in + Lib.make_kn lbl + +type tactic_grammar_obj = { + tacobj_key : KerName.t; + tacobj_local : locality_flag; + tacobj_tacgram : tactic_grammar; + tacobj_body : Id.t list * Tacexpr.glob_tactic_expr; + tacobj_forml : bool; +} + +let pprule pa = { + Pptactic.pptac_level = pa.tacgram_level; + pptac_prods = pa.tacgram_prods; +} + +let check_key key = + if Tacenv.check_alias key then + error "Conflicting tactic notations keys. This can happen when including \ + twice the same module." + +let cache_tactic_notation (_, tobj) = + let key = tobj.tacobj_key in + let () = check_key key in + Tacenv.register_alias key tobj.tacobj_body; + extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram; + Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram) + +let open_tactic_notation i (_, tobj) = + let key = tobj.tacobj_key in + if Int.equal i 1 && not tobj.tacobj_local then + extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram + +let load_tactic_notation i (_, tobj) = + let key = tobj.tacobj_key in + let () = check_key key in + (** Only add the printing and interpretation rules. *) + Tacenv.register_alias key tobj.tacobj_body; + Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram); + if Int.equal i 1 && not tobj.tacobj_local then + extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram + +let subst_tactic_notation (subst, tobj) = + let (ids, body) = tobj.tacobj_body in + { tobj with + tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key; + tacobj_body = (ids, Tacsubst.subst_tactic subst body); + } + +let classify_tactic_notation tacobj = Substitute tacobj + +let inTacticGrammar : tactic_grammar_obj -> obj = + declare_object {(default_object "TacticGrammar") with + open_function = open_tactic_notation; + load_function = load_tactic_notation; + cache_function = cache_tactic_notation; + subst_function = subst_tactic_notation; + classify_function = classify_tactic_notation} + +let cons_production_parameter = function +| TacTerm _ -> None +| TacNonTerm (_, _, id) -> Some id + +let add_glob_tactic_notation local n prods forml ids tac = + let parule = { + tacgram_level = n; + tacgram_prods = prods; + } in + let tacobj = { + tacobj_key = make_fresh_key prods; + tacobj_local = local; + tacobj_tacgram = parule; + tacobj_body = (ids, tac); + tacobj_forml = forml; + } in + Lib.add_anonymous_leaf (inTacticGrammar tacobj) + +let add_tactic_notation local n prods e = + let ids = List.map_filter cons_production_parameter prods in + let prods = List.map interp_prod_item prods in + let tac = Tacintern.glob_tactic_env ids (Global.env()) e in + add_glob_tactic_notation local n prods false ids tac + +(**********************************************************************) +(* ML Tactic entries *) + +exception NonEmptyArgument + +(** ML tactic notations whose use can be restricted to an identifier are added + as true Ltac entries. *) +let extend_atomic_tactic name entries = + let open Tacexpr in + let map_prod prods = + let (hd, rem) = match prods with + | TacTerm s :: rem -> (s, rem) + | _ -> assert false (** Not handled by the ML extension syntax *) + in + let empty_value = function + | TacTerm s -> raise NonEmptyArgument + | TacNonTerm (_, symb, _) -> + let EntryName (typ, e) = prod_item_of_symbol 0 symb in + let Genarg.Rawwit wit = typ in + let inj x = TacArg (Loc.ghost, TacGeneric (Genarg.in_gen typ x)) in + let default = epsilon_value inj e in + match default with + | None -> raise NonEmptyArgument + | Some def -> Tacintern.intern_tactic_or_tacarg Tacintern.fully_empty_glob_sign def + in + try Some (hd, List.map empty_value rem) with NonEmptyArgument -> None + in + let entries = List.map map_prod entries in + let add_atomic i args = match args with + | None -> () + | Some (id, args) -> + let args = List.map (fun a -> Tacexp a) args in + let entry = { mltac_name = name; mltac_index = i } in + let body = TacML (Loc.ghost, entry, args) in + Tacenv.register_ltac false false (Names.Id.of_string id) body + in + List.iteri add_atomic entries + +let add_ml_tactic_notation name prods = + let len = List.length prods in + let iter i prods = + let open Tacexpr in + let get_id = function + | TacTerm s -> None + | TacNonTerm (_, _, id) -> Some id + in + let ids = List.map_filter get_id prods in + let entry = { mltac_name = name; mltac_index = len - i - 1 } in + let map id = Reference (Misctypes.ArgVar (Loc.ghost, id)) in + let tac = TacML (Loc.ghost, entry, List.map map ids) in + add_glob_tactic_notation false 0 prods true ids tac + in + List.iteri iter (List.rev prods); + extend_atomic_tactic name prods + +(**********************************************************************) +(** Ltac quotations *) + +let ltac_quotations = ref String.Set.empty + +let create_ltac_quotation name cast (e, l) = + let () = + if String.Set.mem name !ltac_quotations then + failwith ("Ltac quotation " ^ name ^ " already registered") + in + let () = ltac_quotations := String.Set.add name !ltac_quotations in + let entry = match l with + | None -> Aentry e + | Some l -> Aentryl (e, l) + in +(* let level = Some "1" in *) + let level = None in + let assoc = None in + let rule = + Next (Next (Next (Next (Next (Stop, + Atoken (CLexer.terminal name)), + Atoken (CLexer.terminal ":")), + Atoken (CLexer.terminal "(")), + entry), + Atoken (CLexer.terminal ")")) + in + let action _ v _ _ _ loc = cast (loc, v) in + let gram = (level, assoc, [Rule (rule, action)]) in + Pcoq.grammar_extend Pltac.tactic_arg None (None, [gram]) + +(** Command *) + + +type tacdef_kind = + | NewTac of Id.t + | UpdateTac of Nametab.ltac_constant + +let is_defined_tac kn = + try ignore (Tacenv.interp_ltac kn); true with Not_found -> false + +let warn_unusable_identifier = + CWarnings.create ~name:"unusable-identifier" ~category:"parsing" + (fun id -> strbrk "The Ltac name" ++ spc () ++ pr_id id ++ spc () ++ + strbrk "may be unusable because of a conflict with a notation.") + +let register_ltac local tacl = + let map tactic_body = + match tactic_body with + | Tacexpr.TacticDefinition ((loc,id), body) -> + let kn = Lib.make_kn id in + let id_pp = pr_id id in + let () = if is_defined_tac kn then + CErrors.user_err ~loc + (str "There is already an Ltac named " ++ id_pp ++ str".") + in + let is_shadowed = + try + match Pcoq.parse_string Pltac.tactic (Id.to_string id) with + | Tacexpr.TacArg _ -> false + | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *) + with e when CErrors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) + in + let () = if is_shadowed then warn_unusable_identifier id in + NewTac id, body + | Tacexpr.TacticRedefinition (ident, body) -> + let loc = loc_of_reference ident in + let kn = + try Nametab.locate_tactic (snd (qualid_of_reference ident)) + with Not_found -> + CErrors.user_err ~loc + (str "There is no Ltac named " ++ pr_reference ident ++ str ".") + in + UpdateTac kn, body + in + let rfun = List.map map tacl in + let recvars = + let fold accu (op, _) = match op with + | UpdateTac _ -> accu + | NewTac id -> (Lib.make_path id, Lib.make_kn id) :: accu + in + List.fold_left fold [] rfun + in + let ist = Tacintern.make_empty_glob_sign () in + let map (name, body) = + let body = Flags.with_option Tacintern.strict_check (Tacintern.intern_tactic_or_tacarg ist) body in + (name, body) + in + let defs () = + (** Register locally the tactic to handle recursivity. This function affects + the whole environment, so that we transactify it afterwards. *) + let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in + let () = List.iter iter_rec recvars in + List.map map rfun + in + let defs = Future.transactify defs () in + let iter (def, tac) = match def with + | NewTac id -> + Tacenv.register_ltac false local id tac; + Flags.if_verbose Feedback.msg_info (Nameops.pr_id id ++ str " is defined") + | UpdateTac kn -> + Tacenv.redefine_ltac local kn tac; + let name = Nametab.shortest_qualid_of_tactic kn in + Flags.if_verbose Feedback.msg_info (Libnames.pr_qualid name ++ str " is redefined") + in + List.iter iter defs + +(** Queries *) + +let print_ltacs () = + let entries = KNmap.bindings (Tacenv.ltac_entries ()) in + let sort (kn1, _) (kn2, _) = KerName.compare kn1 kn2 in + let entries = List.sort sort entries in + let map (kn, entry) = + let qid = + try Some (Nametab.shortest_qualid_of_tactic kn) + with Not_found -> None + in + match qid with + | None -> None + | Some qid -> Some (qid, entry.Tacenv.tac_body) + in + let entries = List.map_filter map entries in + let pr_entry (qid, body) = + let (l, t) = match body with + | Tacexpr.TacFun (l, t) -> (l, t) + | _ -> ([], body) + in + let pr_ltac_fun_arg = function + | None -> spc () ++ str "_" + | Some id -> spc () ++ pr_id id + in + hov 2 (pr_qualid qid ++ prlist pr_ltac_fun_arg l) + in + Feedback.msg_notice (prlist_with_sep fnl pr_entry entries) + +(** 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 diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli new file mode 100644 index 000000000..969c118fb --- /dev/null +++ b/plugins/ltac/tacentries.mli @@ -0,0 +1,64 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Tacexpr.tacdef_body list -> unit +(** Adds new Ltac definitions to the environment. *) + +(** {5 Tactic Notations} *) + +type 'a grammar_tactic_prod_item_expr = 'a Pptactic.grammar_tactic_prod_item_expr = +| TacTerm of string +| TacNonTerm of Loc.t * 'a * Names.Id.t + +type raw_argument = string * string option +(** An argument type as provided in Tactic notations, i.e. a string like + "ne_foo_list_opt" together with a separator that only makes sense in the + "_sep" cases. *) + +type argument = Genarg.ArgT.any Extend.user_symbol +(** A fully resolved argument type given as an AST with generic arguments on the + leaves. *) + +val add_tactic_notation : + locality_flag -> int -> raw_argument grammar_tactic_prod_item_expr list -> + raw_tactic_expr -> unit +(** [add_tactic_notation local level prods expr] adds a tactic notation in the + environment at level [level] with locality [local] made of the grammar + productions [prods] and returning the body [expr] *) + +val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type -> unit +(** Register an argument under a given entry name for tactic notations. When + translating [raw_argument] into [argument], atomic names will be first + looked up according to names registered through this function and fallback + to finding an argument by name (as in {!Genarg}) if there is none + matching. *) + +val add_ml_tactic_notation : ml_tactic_name -> + argument grammar_tactic_prod_item_expr list list -> unit +(** A low-level variant of {!add_tactic_notation} used by the TACTIC EXTEND + ML-side macro. *) + +(** {5 Tactic Quotations} *) + +val create_ltac_quotation : string -> + ('grm Loc.located -> raw_tactic_arg) -> ('grm Pcoq.Gram.entry * int option) -> unit +(** [create_ltac_quotation name f e] adds a quotation rule to Ltac, that is, + Ltac grammar now accepts arguments of the form ["name" ":" "(" ")"], and + generates an argument using [f] on the entry parsed by [e]. *) + +(** {5 Queries} *) + +val print_ltacs : unit -> unit +(** Display the list of ltac definitions currently available. *) diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml new file mode 100644 index 000000000..e3c2b4ad5 --- /dev/null +++ b/plugins/ltac/tacenv.ml @@ -0,0 +1,143 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* CErrors.anomaly (str "Unknown tactic alias: " ++ KerName.print key) + +let check_alias key = KNmap.mem key !alias_map + +(** ML tactic extensions (TacML) *) + +type ml_tactic = + Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic + +module MLName = +struct + type t = ml_tactic_name + let compare tac1 tac2 = + let c = String.compare tac1.mltac_tactic tac2.mltac_tactic in + if c = 0 then String.compare tac1.mltac_plugin tac2.mltac_plugin + else c +end + +module MLTacMap = Map.Make(MLName) + +let pr_tacname t = + str t.mltac_plugin ++ str "::" ++ str t.mltac_tactic + +let tac_tab = ref MLTacMap.empty + +let register_ml_tactic ?(overwrite = false) s (t : ml_tactic array) = + let () = + if MLTacMap.mem s !tac_tab then + if overwrite then + tac_tab := MLTacMap.remove s !tac_tab + else + CErrors.anomaly (str "Cannot redeclare tactic " ++ pr_tacname s ++ str ".") + in + tac_tab := MLTacMap.add s t !tac_tab + +let interp_ml_tactic { mltac_name = s; mltac_index = i } = + try + let tacs = MLTacMap.find s !tac_tab in + let () = if Array.length tacs <= i then raise Not_found in + tacs.(i) + with Not_found -> + CErrors.user_err + (str "The tactic " ++ pr_tacname s ++ str " is not installed.") + +(***************************************************************************) +(* Tactic registration *) + +(* Summary and Object declaration *) + +open Nametab +open Libobject + +type ltac_entry = { + tac_for_ml : bool; + tac_body : glob_tactic_expr; + tac_redef : ModPath.t list; +} + +let mactab = + Summary.ref (KNmap.empty : ltac_entry KNmap.t) + ~name:"tactic-definition" + +let ltac_entries () = !mactab + +let interp_ltac r = (KNmap.find r !mactab).tac_body + +let is_ltac_for_ml_tactic r = (KNmap.find r !mactab).tac_for_ml + +let add kn b t = + let entry = { tac_for_ml = b; tac_body = t; tac_redef = [] } in + mactab := KNmap.add kn entry !mactab + +let replace kn path t = + let (path, _, _) = KerName.repr path in + let entry _ e = { e with tac_body = t; tac_redef = path :: e.tac_redef } in + mactab := KNmap.modify kn entry !mactab + +let load_md i ((sp, kn), (local, id, b, t)) = match id with +| None -> + let () = if not local then Nametab.push_tactic (Until i) sp kn in + add kn b t +| Some kn0 -> replace kn0 kn t + +let open_md i ((sp, kn), (local, id, b, t)) = match id with +| None -> + let () = if not local then Nametab.push_tactic (Exactly i) sp kn in + add kn b t +| Some kn0 -> replace kn0 kn t + +let cache_md ((sp, kn), (local, id ,b, t)) = match id with +| None -> + let () = Nametab.push_tactic (Until 1) sp kn in + add kn b t +| Some kn0 -> replace kn0 kn t + +let subst_kind subst id = match id with +| None -> None +| Some kn -> Some (Mod_subst.subst_kn subst kn) + +let subst_md (subst, (local, id, b, t)) = + (local, subst_kind subst id, b, Tacsubst.subst_tactic subst t) + +let classify_md (local, _, _, _ as o) = Substitute o + +let inMD : bool * Nametab.ltac_constant option * bool * glob_tactic_expr -> obj = + declare_object {(default_object "TAC-DEFINITION") with + cache_function = cache_md; + load_function = load_md; + open_function = open_md; + subst_function = subst_md; + classify_function = classify_md} + +let register_ltac for_ml local id tac = + ignore (Lib.add_leaf id (inMD (local, None, for_ml, tac))) + +let redefine_ltac local kn tac = + Lib.add_anonymous_leaf (inMD (local, Some kn, false, tac)) diff --git a/plugins/ltac/tacenv.mli b/plugins/ltac/tacenv.mli new file mode 100644 index 000000000..94e14223a --- /dev/null +++ b/plugins/ltac/tacenv.mli @@ -0,0 +1,75 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* alias_tactic -> unit +(** Register a tactic alias. *) + +val interp_alias : alias -> alias_tactic +(** Recover the the body of an alias. Raises an anomaly if it does not exist. *) + +val check_alias : alias -> bool +(** Returns [true] if an alias is defined, false otherwise. *) + +(** {5 Coq tactic definitions} *) + +val register_ltac : bool -> bool -> Id.t -> glob_tactic_expr -> unit +(** Register a new Ltac with the given name and body. + + The first boolean indicates whether this is done from ML side, rather than + Coq side. If the second boolean flag is set to true, then this is a local + definition. It also puts the Ltac name in the nametab, so that it can be + used unqualified. *) + +val redefine_ltac : bool -> KerName.t -> glob_tactic_expr -> unit +(** Replace a Ltac with the given name and body. If the boolean flag is set + to true, then this is a local redefinition. *) + +val interp_ltac : KerName.t -> glob_tactic_expr +(** Find a user-defined tactic by name. Raise [Not_found] if it is absent. *) + +val is_ltac_for_ml_tactic : KerName.t -> bool +(** Whether the tactic is defined from ML-side *) + +type ltac_entry = { + tac_for_ml : bool; + (** Whether the tactic is defined from ML-side *) + tac_body : glob_tactic_expr; + (** The current body of the tactic *) + tac_redef : ModPath.t list; + (** List of modules redefining the tactic in reverse chronological order *) +} + +val ltac_entries : unit -> ltac_entry KNmap.t +(** Low-level access to all Ltac entries currently defined. *) + +(** {5 ML tactic extensions} *) + +type ml_tactic = + Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic +(** Type of external tactics, used by [TacML]. *) + +val register_ml_tactic : ?overwrite:bool -> ml_tactic_name -> ml_tactic array -> unit +(** Register an external tactic. *) + +val interp_ml_tactic : ml_tactic_entry -> ml_tactic +(** Get the named tactic. Raises a user error if it does not exist. *) diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli new file mode 100644 index 000000000..9c25a1645 --- /dev/null +++ b/plugins/ltac/tacexpr.mli @@ -0,0 +1,396 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'r Sigma.t -> ('a, 'r) Sigma.sigma } + +type delayed_open_constr_with_bindings = Term.constr with_bindings delayed_open + +type delayed_open_constr = Term.constr delayed_open + +type intro_pattern = delayed_open_constr intro_pattern_expr located +type intro_patterns = delayed_open_constr intro_pattern_expr located list +type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr located +type intro_pattern_naming = intro_pattern_naming_expr located + +(** Generic expressions for atomic tactics *) + +type 'a gen_atomic_tactic_expr = + (* Basic tactics *) + | TacIntroPattern of evars_flag * 'dtrm intro_pattern_expr located list + | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list * + ('nam * 'dtrm intro_pattern_expr located option) option + | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option + | TacCase of evars_flag * 'trm with_bindings_arg + | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list + | TacMutualCofix of Id.t * (Id.t * 'trm) list + | TacAssert of + bool * 'tacexpr option option * + 'dtrm intro_pattern_expr located option * 'trm + | TacGeneralize of ('trm with_occurrences * Name.t) list + | TacLetTac of Name.t * 'trm * 'nam clause_expr * letin_flag * + intro_pattern_naming_expr located option + + (* Derived basic tactics *) + | TacInductionDestruct of + rec_flag * evars_flag * ('trm,'dtrm,'nam) induction_clause_list + + (* Conversion *) + | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr + | TacChange of 'pat option * 'dtrm * 'nam clause_expr + + (* Equality and inversion *) + | TacRewrite of evars_flag * + (bool * multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * + (* spiwack: using ['dtrm] here is a small hack, may not be + stable by a change in the representation of delayed + terms. Because, in fact, it is the whole "with_bindings" + which is delayed. But because the "t" level for ['dtrm] is + uninterpreted, it works fine here too, and avoid more + disruption of this file. *) + 'tacexpr option + | TacInversion of ('trm,'dtrm,'nam) inversion_strength * quantified_hypothesis + +constraint 'a = < + term:'trm; + dterm: 'dtrm; + pattern:'pat; + constant:'cst; + reference:'ref; + name:'nam; + tacexpr:'tacexpr; + level:'lev +> + +(** Possible arguments of a tactic definition *) + +type 'a gen_tactic_arg = + | TacGeneric of 'lev generic_argument + | ConstrMayEval of ('trm,'cst,'pat) may_eval + | Reference of 'ref + | TacCall of Loc.t * 'ref * + 'a gen_tactic_arg list + | TacFreshId of string or_var list + | Tacexp of 'tacexpr + | TacPretype of 'trm + | TacNumgoals + +constraint 'a = < + term:'trm; + dterm: 'dtrm; + pattern:'pat; + constant:'cst; + reference:'ref; + name:'nam; + tacexpr:'tacexpr; + level:'lev +> + +(** Generic ltac expressions. + 't : terms, 'p : patterns, 'c : constants, 'i : inductive, + 'r : ltac refs, 'n : idents, 'l : levels *) + +and 'a gen_tactic_expr = + | TacAtom of Loc.t * 'a gen_atomic_tactic_expr + | TacThen of + 'a gen_tactic_expr * + 'a gen_tactic_expr + | TacDispatch of + 'a gen_tactic_expr list + | TacExtendTac of + 'a gen_tactic_expr array * + 'a gen_tactic_expr * + 'a gen_tactic_expr array + | TacThens of + 'a gen_tactic_expr * + 'a gen_tactic_expr list + | TacThens3parts of + 'a gen_tactic_expr * + 'a gen_tactic_expr array * + 'a gen_tactic_expr * + 'a gen_tactic_expr array + | TacFirst of 'a gen_tactic_expr list + | TacComplete of 'a gen_tactic_expr + | TacSolve of 'a gen_tactic_expr list + | TacTry of 'a gen_tactic_expr + | TacOr of + 'a gen_tactic_expr * + 'a gen_tactic_expr + | TacOnce of + 'a gen_tactic_expr + | TacExactlyOnce of + 'a gen_tactic_expr + | TacIfThenCatch of + 'a gen_tactic_expr * + 'a gen_tactic_expr * + 'a gen_tactic_expr + | TacOrelse of + 'a gen_tactic_expr * + 'a gen_tactic_expr + | TacDo of int or_var * 'a gen_tactic_expr + | TacTimeout of int or_var * 'a gen_tactic_expr + | TacTime of string option * 'a gen_tactic_expr + | TacRepeat of 'a gen_tactic_expr + | TacProgress of 'a gen_tactic_expr + | TacShowHyps of 'a gen_tactic_expr + | TacAbstract of + 'a gen_tactic_expr * Id.t option + | TacId of 'n message_token list + | TacFail of global_flag * int or_var * 'n message_token list + | TacInfo of 'a gen_tactic_expr + | TacLetIn of rec_flag * + (Id.t located * 'a gen_tactic_arg) list * + 'a gen_tactic_expr + | TacMatch of lazy_flag * + 'a gen_tactic_expr * + ('p,'a gen_tactic_expr) match_rule list + | TacMatchGoal of lazy_flag * direction_flag * + ('p,'a gen_tactic_expr) match_rule list + | TacFun of 'a gen_tactic_fun_ast + | TacArg of 'a gen_tactic_arg located + | TacSelect of goal_selector * 'a gen_tactic_expr + (* For ML extensions *) + | TacML of Loc.t * ml_tactic_entry * 'a gen_tactic_arg list + (* For syntax extensions *) + | TacAlias of Loc.t * KerName.t * 'a gen_tactic_arg list + +constraint 'a = < + term:'t; + dterm: 'dtrm; + pattern:'p; + constant:'c; + reference:'r; + name:'n; + tacexpr:'tacexpr; + level:'l +> + +and 'a gen_tactic_fun_ast = + Id.t option list * 'a gen_tactic_expr + +constraint 'a = < + term:'t; + dterm: 'dtrm; + pattern:'p; + constant:'c; + reference:'r; + name:'n; + tacexpr:'te; + level:'l +> + +(** Globalized tactics *) + +type g_trm = glob_constr_and_expr +type g_pat = glob_constr_pattern_and_expr +type g_cst = evaluable_global_reference and_short_name or_var +type g_ref = ltac_constant located or_var +type g_nam = Id.t located + +type g_dispatch = < + term:g_trm; + dterm:g_trm; + pattern:g_pat; + constant:g_cst; + reference:g_ref; + name:g_nam; + tacexpr:glob_tactic_expr; + level:glevel +> + +and glob_tactic_expr = + g_dispatch gen_tactic_expr + +type glob_atomic_tactic_expr = + g_dispatch gen_atomic_tactic_expr + +type glob_tactic_arg = + g_dispatch gen_tactic_arg + +(** Raw tactics *) + +type r_trm = constr_expr +type r_pat = constr_pattern_expr +type r_cst = reference or_by_notation +type r_ref = reference +type r_nam = Id.t located +type r_lev = rlevel + +type r_dispatch = < + term:r_trm; + dterm:r_trm; + pattern:r_pat; + constant:r_cst; + reference:r_ref; + name:r_nam; + tacexpr:raw_tactic_expr; + level:rlevel +> + +and raw_tactic_expr = + r_dispatch gen_tactic_expr + +type raw_atomic_tactic_expr = + r_dispatch gen_atomic_tactic_expr + +type raw_tactic_arg = + r_dispatch gen_tactic_arg + +(** Interpreted tactics *) + +type t_trm = Term.constr +type t_pat = constr_pattern +type t_cst = evaluable_global_reference +type t_ref = ltac_constant located +type t_nam = Id.t + +type t_dispatch = < + term:t_trm; + dterm:g_trm; + pattern:t_pat; + constant:t_cst; + reference:t_ref; + name:t_nam; + tacexpr:unit; + level:tlevel +> + +type atomic_tactic_expr = + t_dispatch gen_atomic_tactic_expr + +(** Misc *) + +type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen +type glob_red_expr = (g_trm, g_cst, g_pat) red_expr_gen + +(** Traces *) + +type ltac_call_kind = + | LtacMLCall of glob_tactic_expr + | LtacNotationCall of KerName.t + | LtacNameCall of ltac_constant + | LtacAtomCall of glob_atomic_tactic_expr + | LtacVarCall of Id.t * glob_tactic_expr + | LtacConstrInterp of Glob_term.glob_constr * Pretyping.ltac_var_map + +type ltac_trace = (Loc.t * ltac_call_kind) list + +type tacdef_body = + | TacticDefinition of Id.t Loc.located * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) + | TacticRedefinition of reference * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml new file mode 100644 index 000000000..763e0dc22 --- /dev/null +++ b/plugins/ltac/tacintern.ml @@ -0,0 +1,812 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Anonymous + | Name id -> Name (intern_ident l ist id) + +let strict_check = ref false + +let adjust_loc loc = if !strict_check then dloc else loc + +(* Globalize a name which must be bound -- actually just check it is bound *) +let intern_hyp ist (loc,id as locid) = + if not !strict_check then + locid + else if find_ident id ist then + (dloc,id) + else + Pretype_errors.error_var_not_found ~loc id + +let intern_or_var f ist = function + | ArgVar locid -> ArgVar (intern_hyp ist locid) + | ArgArg x -> ArgArg (f x) + +let intern_int_or_var = intern_or_var (fun (n : int) -> n) +let intern_string_or_var = intern_or_var (fun (s : string) -> s) + +let intern_global_reference ist = function + | Ident (loc,id) when find_var id ist -> ArgVar (loc,id) + | r -> + let loc,_ as lqid = qualid_of_reference r in + try ArgArg (loc,locate_global_with_alias lqid) + with Not_found -> error_global_not_found (snd lqid) + +let intern_ltac_variable ist = function + | Ident (loc,id) -> + if find_var id ist then + (* A local variable of any type *) + ArgVar (loc,id) + else raise Not_found + | _ -> + raise Not_found + +let intern_constr_reference strict ist = function + | Ident (_,id) as r when not strict && find_hyp id ist -> + GVar (dloc,id), Some (CRef (r,None)) + | Ident (_,id) as r when find_var id ist -> + GVar (dloc,id), if strict then None else Some (CRef (r,None)) + | r -> + let loc,_ as lqid = qualid_of_reference r in + GRef (loc,locate_global_with_alias lqid,None), + if strict then None else Some (CRef (r,None)) + +let intern_move_location ist = function + | MoveAfter id -> MoveAfter (intern_hyp ist id) + | MoveBefore id -> MoveBefore (intern_hyp ist id) + | MoveFirst -> MoveFirst + | MoveLast -> MoveLast + +(* Internalize an isolated reference in position of tactic *) + +let intern_isolated_global_tactic_reference r = + let (loc,qid) = qualid_of_reference r in + TacCall (loc,ArgArg (loc,locate_tactic qid),[]) + +let intern_isolated_tactic_reference strict ist r = + (* An ltac reference *) + try Reference (intern_ltac_variable ist r) + with Not_found -> + (* A global tactic *) + try intern_isolated_global_tactic_reference r + with Not_found -> + (* Tolerance for compatibility, allow not to use "constr:" *) + try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) + with Not_found -> + (* Reference not found *) + error_global_not_found (snd (qualid_of_reference r)) + +(* Internalize an applied tactic reference *) + +let intern_applied_global_tactic_reference r = + let (loc,qid) = qualid_of_reference r in + ArgArg (loc,locate_tactic qid) + +let intern_applied_tactic_reference ist r = + (* An ltac reference *) + try intern_ltac_variable ist r + with Not_found -> + (* A global tactic *) + try intern_applied_global_tactic_reference r + with Not_found -> + (* Reference not found *) + error_global_not_found (snd (qualid_of_reference r)) + +(* Intern a reference parsed in a non-tactic entry *) + +let intern_non_tactic_reference strict ist r = + (* An ltac reference *) + try Reference (intern_ltac_variable ist r) + with Not_found -> + (* A constr reference *) + try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) + with Not_found -> + (* Tolerance for compatibility, allow not to use "ltac:" *) + try intern_isolated_global_tactic_reference r + with Not_found -> + (* By convention, use IntroIdentifier for unbound ident, when not in a def *) + match r with + | Ident (loc,id) when not strict -> + let ipat = in_gen (glbwit wit_intro_pattern) (loc, IntroNaming (IntroIdentifier id)) in + TacGeneric ipat + | _ -> + (* Reference not found *) + error_global_not_found (snd (qualid_of_reference r)) + +let intern_message_token ist = function + | (MsgString _ | MsgInt _ as x) -> x + | MsgIdent id -> MsgIdent (intern_hyp ist id) + +let intern_message ist = List.map (intern_message_token ist) + +let intern_quantified_hypothesis ist = function + | AnonHyp n -> AnonHyp n + | NamedHyp id -> + (* Uncomment to disallow "intros until n" in ltac when n is not bound *) + NamedHyp ((*snd (intern_hyp ist (dloc,*)id(* ))*)) + +let intern_binding_name ist x = + (* We use identifier both for variables and binding names *) + (* Todo: consider the body of the lemma to which the binding refer + and if a term w/o ltac vars, check the name is indeed quantified *) + x + +let intern_constr_gen allow_patvar isarity {ltacvars=lfun; genv=env} c = + let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in + let scope = if isarity then Pretyping.IsType else Pretyping.WithoutTypeConstraint in + let ltacvars = { + Constrintern.ltac_vars = lfun; + ltac_bound = Id.Set.empty; + } in + let c' = + warn (Constrintern.intern_gen scope ~allow_patvar ~ltacvars env) c + in + (c',if !strict_check then None else Some c) + +let intern_constr = intern_constr_gen false false +let intern_type = intern_constr_gen false true + +(* Globalize bindings *) +let intern_binding ist (loc,b,c) = + (loc,intern_binding_name ist b,intern_constr ist c) + +let intern_bindings ist = function + | NoBindings -> NoBindings + | ImplicitBindings l -> ImplicitBindings (List.map (intern_constr ist) l) + | ExplicitBindings l -> ExplicitBindings (List.map (intern_binding ist) l) + +let intern_constr_with_bindings ist (c,bl) = + (intern_constr ist c, intern_bindings ist bl) + +let intern_constr_with_bindings_arg ist (clear,c) = + (clear,intern_constr_with_bindings ist c) + +let rec intern_intro_pattern lf ist = function + | loc, IntroNaming pat -> + loc, IntroNaming (intern_intro_pattern_naming lf ist pat) + | loc, IntroAction pat -> + loc, IntroAction (intern_intro_pattern_action lf ist pat) + | loc, IntroForthcoming _ as x -> x + +and intern_intro_pattern_naming lf ist = function + | IntroIdentifier id -> + IntroIdentifier (intern_ident lf ist id) + | IntroFresh id -> + IntroFresh (intern_ident lf ist id) + | IntroAnonymous as x -> x + +and intern_intro_pattern_action lf ist = function + | IntroOrAndPattern l -> + IntroOrAndPattern (intern_or_and_intro_pattern lf ist l) + | IntroInjection l -> + IntroInjection (List.map (intern_intro_pattern lf ist) l) + | IntroWildcard | IntroRewrite _ as x -> x + | IntroApplyOn (c,pat) -> + IntroApplyOn (intern_constr ist c, intern_intro_pattern lf ist pat) + +and intern_or_and_intro_pattern lf ist = function + | IntroAndPattern l -> + IntroAndPattern (List.map (intern_intro_pattern lf ist) l) + | IntroOrPattern ll -> + IntroOrPattern (List.map (List.map (intern_intro_pattern lf ist)) ll) + +let intern_or_and_intro_pattern_loc lf ist = function + | ArgVar (_,id) as x -> + if find_var id ist then x + else error "Disjunctive/conjunctive introduction pattern expected." + | ArgArg (loc,l) -> ArgArg (loc,intern_or_and_intro_pattern lf ist l) + +let intern_intro_pattern_naming_loc lf ist (loc,pat) = + (loc,intern_intro_pattern_naming lf ist pat) + + (* TODO: catch ltac vars *) +let intern_destruction_arg ist = function + | clear,ElimOnConstr c -> clear,ElimOnConstr (intern_constr_with_bindings ist c) + | clear,ElimOnAnonHyp n as x -> x + | clear,ElimOnIdent (loc,id) -> + if !strict_check then + (* If in a defined tactic, no intros-until *) + match intern_constr ist (CRef (Ident (dloc,id), None)) with + | GVar (loc,id),_ -> clear,ElimOnIdent (loc,id) + | c -> clear,ElimOnConstr (c,NoBindings) + else + clear,ElimOnIdent (loc,id) + +let short_name = function + | AN (Ident (loc,id)) when not !strict_check -> Some (loc,id) + | _ -> None + +let intern_evaluable_global_reference ist r = + let lqid = qualid_of_reference r in + try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true lqid) + with Not_found -> + match r with + | Ident (loc,id) when not !strict_check -> EvalVarRef id + | _ -> error_global_not_found (snd lqid) + +let intern_evaluable_reference_or_by_notation ist = function + | AN r -> intern_evaluable_global_reference ist r + | ByNotation (loc,ntn,sc) -> + evaluable_of_global_reference ist.genv + (Notation.interp_notation_as_global_reference loc + (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) + +(* Globalize a reduction expression *) +let intern_evaluable ist = function + | AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id) + | AN (Ident (loc,id)) when not !strict_check && find_hyp id ist -> + ArgArg (EvalVarRef id, Some (loc,id)) + | r -> + let e = intern_evaluable_reference_or_by_notation ist r in + let na = short_name r in + ArgArg (e,na) + +let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid) + +let intern_flag ist red = + { red with rConst = List.map (intern_evaluable ist) red.rConst } + +let intern_constr_with_occurrences ist (l,c) = (l,intern_constr ist c) + +let intern_constr_pattern ist ~as_type ~ltacvars pc = + let ltacvars = { + Constrintern.ltac_vars = ltacvars; + ltac_bound = Id.Set.empty; + } in + let metas,pat = Constrintern.intern_constr_pattern + ist.genv ~as_type ~ltacvars pc + in + let (glob,_ as c) = intern_constr_gen true false ist pc in + let bound_names = Glob_ops.bound_glob_vars glob in + metas,(bound_names,c,pat) + +let dummy_pat = PRel 0 + +let intern_typed_pattern ist p = + (* we cannot ensure in non strict mode that the pattern is closed *) + (* keeping a constr_expr copy is too complicated and we want anyway to *) + (* type it, so we remember the pattern as a glob_constr only *) + let (glob,_ as c) = intern_constr_gen true false ist p in + let bound_names = Glob_ops.bound_glob_vars glob in + (bound_names,c,dummy_pat) + +let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = + let interp_ref r = + try Inl (intern_evaluable ist r) + with e when Logic.catchable_exception e -> + (* Compatibility. In practice, this means that the code above + is useless. Still the idea of having either an evaluable + ref or a pattern seems interesting, with "head" reduction + in case of an evaluable ref, and "strong" reduction in the + subterm matched when a pattern *) + let loc = loc_of_smart_reference r in + let r = match r with + | AN r -> r + | _ -> Qualid (loc,qualid_of_path (path_of_global (smart_global r))) in + let sign = { Constrintern.ltac_vars = ist.ltacvars; Constrintern.ltac_bound = Id.Set.empty } in + let c = Constrintern.interp_reference sign r in + match c with + | GRef (_,r,None) -> + Inl (ArgArg (evaluable_of_global_reference ist.genv r,None)) + | GVar (_,id) -> + let r = evaluable_of_global_reference ist.genv (VarRef id) in + Inl (ArgArg (r,None)) + | _ -> + let bound_names = Glob_ops.bound_glob_vars c in + Inr (bound_names,(c,None),dummy_pat) in + (l, match p with + | Inl r -> interp_ref r + | Inr (CAppExpl(_,(None,r,None),[])) -> + (* We interpret similarly @ref and ref *) + interp_ref (AN r) + | Inr c -> + Inr (intern_typed_pattern ist c)) + +(* This seems fairly hacky, but it's the first way I've found to get proper + globalization of [unfold]. --adamc *) +let dump_glob_red_expr = function + | Unfold occs -> List.iter (fun (_, r) -> + try + Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) + (Smartlocate.smart_global r) + with e when CErrors.noncritical e -> ()) occs + | Cbv grf | Lazy grf -> + List.iter (fun r -> + try + Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) + (Smartlocate.smart_global r) + with e when CErrors.noncritical e -> ()) grf.rConst + | _ -> () + +let intern_red_expr ist = function + | Unfold l -> Unfold (List.map (intern_unfold ist) l) + | Fold l -> Fold (List.map (intern_constr ist) l) + | Cbv f -> Cbv (intern_flag ist f) + | Cbn f -> Cbn (intern_flag ist f) + | Lazy f -> Lazy (intern_flag ist f) + | Pattern l -> Pattern (List.map (intern_constr_with_occurrences ist) l) + | Simpl (f,o) -> + Simpl (intern_flag ist f, + Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) + | CbvVm o -> CbvVm (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) + | CbvNative o -> CbvNative (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) + | (Red _ | Hnf | ExtraRedExpr _ as r ) -> r + +let intern_in_hyp_as ist lf (id,ipat) = + (intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat) + +let intern_hyp_list ist = List.map (intern_hyp ist) + +let intern_inversion_strength lf ist = function + | NonDepInversion (k,idl,ids) -> + NonDepInversion (k,intern_hyp_list ist idl, + Option.map (intern_or_and_intro_pattern_loc lf ist) ids) + | DepInversion (k,copt,ids) -> + DepInversion (k, Option.map (intern_constr ist) copt, + Option.map (intern_or_and_intro_pattern_loc lf ist) ids) + | InversionUsing (c,idl) -> + InversionUsing (intern_constr ist c, intern_hyp_list ist idl) + +(* Interprets an hypothesis name *) +let intern_hyp_location ist ((occs,id),hl) = + ((Locusops.occurrences_map (List.map (intern_int_or_var ist)) occs, + intern_hyp ist id), hl) + +(* Reads a pattern *) +let intern_pattern ist ?(as_type=false) ltacvars = function + | Subterm (b,ido,pc) -> + let (metas,pc) = intern_constr_pattern ist ~as_type:false ~ltacvars pc in + ido, metas, Subterm (b,ido,pc) + | Term pc -> + let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in + None, metas, Term pc + +let intern_constr_may_eval ist = function + | ConstrEval (r,c) -> ConstrEval (intern_red_expr ist r,intern_constr ist c) + | ConstrContext (locid,c) -> + ConstrContext (intern_hyp ist locid,intern_constr ist c) + | ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c) + | ConstrTerm c -> ConstrTerm (intern_constr ist c) + +let name_cons accu = function +| Anonymous -> accu +| Name id -> Id.Set.add id accu + +let opt_cons accu = function +| None -> accu +| Some id -> Id.Set.add id accu + +(* Reads the hypotheses of a "match goal" rule *) +let rec intern_match_goal_hyps ist ?(as_type=false) lfun = function + | (Hyp ((_,na) as locna,mp))::tl -> + let ido, metas1, pat = intern_pattern ist ~as_type:true lfun mp in + let lfun, metas2, hyps = intern_match_goal_hyps ist lfun tl in + let lfun' = name_cons (opt_cons lfun ido) na in + lfun', metas1@metas2, Hyp (locna,pat)::hyps + | (Def ((_,na) as locna,mv,mp))::tl -> + let ido, metas1, patv = intern_pattern ist ~as_type:false lfun mv in + let ido', metas2, patt = intern_pattern ist ~as_type:true lfun mp in + let lfun, metas3, hyps = intern_match_goal_hyps ist ~as_type lfun tl in + let lfun' = name_cons (opt_cons (opt_cons lfun ido) ido') na in + lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps + | [] -> lfun, [], [] + +(* Utilities *) +let extract_let_names lrc = + let fold accu ((loc, name), _) = + if Id.Set.mem name accu then user_err ~loc + ~hdr:"glob_tactic" (str "This variable is bound several times.") + else Id.Set.add name accu + in + List.fold_left fold Id.Set.empty lrc + +let clause_app f = function + { onhyps=None; concl_occs=nl } -> + { onhyps=None; concl_occs=nl } + | { onhyps=Some l; concl_occs=nl } -> + { onhyps=Some(List.map f l); concl_occs=nl} + +(* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *) +let rec intern_atomic lf ist x = + match (x:raw_atomic_tactic_expr) with + (* Basic tactics *) + | TacIntroPattern (ev,l) -> + TacIntroPattern (ev,List.map (intern_intro_pattern lf ist) l) + | TacApply (a,ev,cb,inhyp) -> + TacApply (a,ev,List.map (intern_constr_with_bindings_arg ist) cb, + Option.map (intern_in_hyp_as ist lf) inhyp) + | TacElim (ev,cb,cbo) -> + TacElim (ev,intern_constr_with_bindings_arg ist cb, + Option.map (intern_constr_with_bindings ist) cbo) + | TacCase (ev,cb) -> TacCase (ev,intern_constr_with_bindings_arg ist cb) + | TacMutualFix (id,n,l) -> + let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in + TacMutualFix (intern_ident lf ist id, n, List.map f l) + | TacMutualCofix (id,l) -> + let f (id,c) = (intern_ident lf ist id,intern_type ist c) in + TacMutualCofix (intern_ident lf ist id, List.map f l) + | TacAssert (b,otac,ipat,c) -> + TacAssert (b,Option.map (Option.map (intern_pure_tactic ist)) otac, + Option.map (intern_intro_pattern lf ist) ipat, + intern_constr_gen false (not (Option.is_empty otac)) ist c) + | TacGeneralize cl -> + TacGeneralize (List.map (fun (c,na) -> + intern_constr_with_occurrences ist c, + intern_name lf ist na) cl) + | TacLetTac (na,c,cls,b,eqpat) -> + let na = intern_name lf ist na in + TacLetTac (na,intern_constr ist c, + (clause_app (intern_hyp_location ist) cls),b, + (Option.map (intern_intro_pattern_naming_loc lf ist) eqpat)) + + (* Derived basic tactics *) + | TacInductionDestruct (ev,isrec,(l,el)) -> + TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats),cls) -> + (intern_destruction_arg ist c, + (Option.map (intern_intro_pattern_naming_loc lf ist) ipato, + Option.map (intern_or_and_intro_pattern_loc lf ist) ipats), + Option.map (clause_app (intern_hyp_location ist)) cls)) l, + Option.map (intern_constr_with_bindings ist) el)) + (* Conversion *) + | TacReduce (r,cl) -> + dump_glob_red_expr r; + TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl) + | TacChange (None,c,cl) -> + let is_onhyps = match cl.onhyps with + | None | Some [] -> true + | _ -> false + in + let is_onconcl = match cl.concl_occs with + | AllOccurrences | NoOccurrences -> true + | _ -> false + in + TacChange (None, + (if is_onhyps && is_onconcl + then intern_type ist c else intern_constr ist c), + clause_app (intern_hyp_location ist) cl) + | TacChange (Some p,c,cl) -> + TacChange (Some (intern_typed_pattern ist p),intern_constr ist c, + clause_app (intern_hyp_location ist) cl) + + (* Equality and inversion *) + | TacRewrite (ev,l,cl,by) -> + TacRewrite + (ev, + List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings_arg ist c)) l, + clause_app (intern_hyp_location ist) cl, + Option.map (intern_pure_tactic ist) by) + | TacInversion (inv,hyp) -> + TacInversion (intern_inversion_strength lf ist inv, + intern_quantified_hypothesis ist hyp) + +and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac) + +and intern_tactic_seq onlytac ist = function + | TacAtom (loc,t) -> + let lf = ref ist.ltacvars in + let t = intern_atomic lf ist t in + !lf, TacAtom (adjust_loc loc, t) + | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun) + | TacLetIn (isrec,l,u) -> + let ltacvars = Id.Set.union (extract_let_names l) ist.ltacvars in + let ist' = { ist with ltacvars } in + let l = List.map (fun (n,b) -> + (n,intern_tacarg !strict_check false (if isrec then ist' else ist) b)) l in + ist.ltacvars, TacLetIn (isrec,l,intern_tactic onlytac ist' u) + + | TacMatchGoal (lz,lr,lmr) -> + ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule onlytac ist ~as_type:true lmr) + | TacMatch (lz,c,lmr) -> + ist.ltacvars, + TacMatch (lz,intern_tactic_or_tacarg ist c,intern_match_rule onlytac ist lmr) + | TacId l -> ist.ltacvars, TacId (intern_message ist l) + | TacFail (g,n,l) -> + ist.ltacvars, TacFail (g,intern_int_or_var ist n,intern_message ist l) + | TacProgress tac -> ist.ltacvars, TacProgress (intern_pure_tactic ist tac) + | TacShowHyps tac -> ist.ltacvars, TacShowHyps (intern_pure_tactic ist tac) + | TacAbstract (tac,s) -> + ist.ltacvars, TacAbstract (intern_pure_tactic ist tac,s) + | TacThen (t1,t2) -> + let lfun', t1 = intern_tactic_seq onlytac ist t1 in + let lfun'', t2 = intern_tactic_seq onlytac { ist with ltacvars = lfun' } t2 in + lfun'', TacThen (t1,t2) + | TacDispatch tl -> + ist.ltacvars , TacDispatch (List.map (intern_pure_tactic ist) tl) + | TacExtendTac (tf,t,tl) -> + ist.ltacvars , + TacExtendTac (Array.map (intern_pure_tactic ist) tf, + intern_pure_tactic ist t, + Array.map (intern_pure_tactic ist) tl) + | TacThens3parts (t1,tf,t2,tl) -> + let lfun', t1 = intern_tactic_seq onlytac ist t1 in + let ist' = { ist with ltacvars = lfun' } in + (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) + lfun', TacThens3parts (t1,Array.map (intern_pure_tactic ist') tf,intern_pure_tactic ist' t2, + Array.map (intern_pure_tactic ist') tl) + | TacThens (t,tl) -> + let lfun', t = intern_tactic_seq true ist t in + let ist' = { ist with ltacvars = lfun' } in + (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) + lfun', TacThens (t, List.map (intern_pure_tactic ist') tl) + | TacDo (n,tac) -> + ist.ltacvars, TacDo (intern_int_or_var ist n,intern_pure_tactic ist tac) + | TacTry tac -> ist.ltacvars, TacTry (intern_pure_tactic ist tac) + | TacInfo tac -> ist.ltacvars, TacInfo (intern_pure_tactic ist tac) + | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_pure_tactic ist tac) + | TacTimeout (n,tac) -> + ist.ltacvars, TacTimeout (intern_int_or_var ist n,intern_tactic onlytac ist tac) + | TacTime (s,tac) -> + ist.ltacvars, TacTime (s,intern_tactic onlytac ist tac) + | TacOr (tac1,tac2) -> + ist.ltacvars, TacOr (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2) + | TacOnce tac -> + ist.ltacvars, TacOnce (intern_pure_tactic ist tac) + | TacExactlyOnce tac -> + ist.ltacvars, TacExactlyOnce (intern_pure_tactic ist tac) + | TacIfThenCatch (tac,tact,tace) -> + ist.ltacvars, + TacIfThenCatch ( + intern_pure_tactic ist tac, + intern_pure_tactic ist tact, + intern_pure_tactic ist tace) + | TacOrelse (tac1,tac2) -> + ist.ltacvars, TacOrelse (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2) + | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l) + | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l) + | TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac) + | TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a + | TacSelect (sel, tac) -> + ist.ltacvars, TacSelect (sel, intern_pure_tactic ist tac) + + (* For extensions *) + | TacAlias (loc,s,l) -> + let l = List.map (intern_tacarg !strict_check false ist) l in + ist.ltacvars, TacAlias (loc,s,l) + | TacML (loc,opn,l) -> + let _ignore = Tacenv.interp_ml_tactic opn in + ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_tacarg !strict_check false ist) l) + +and intern_tactic_as_arg loc onlytac ist a = + match intern_tacarg !strict_check onlytac ist a with + | TacCall _ | Reference _ + | TacGeneric _ as a -> TacArg (loc,a) + | Tacexp a -> a + | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> + if onlytac then error_tactic_expected ~loc else TacArg (loc,a) + +and intern_tactic_or_tacarg ist = intern_tactic false ist + +and intern_pure_tactic ist = intern_tactic true ist + +and intern_tactic_fun ist (var,body) = + let lfun = List.fold_left opt_cons ist.ltacvars var in + (var,intern_tactic_or_tacarg { ist with ltacvars = lfun } body) + +and intern_tacarg strict onlytac ist = function + | Reference r -> intern_non_tactic_reference strict ist r + | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c) + | TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f + | TacCall (loc,f,l) -> + TacCall (loc, + intern_applied_tactic_reference ist f, + List.map (intern_tacarg !strict_check false ist) l) + | TacFreshId x -> TacFreshId (List.map (intern_string_or_var ist) x) + | TacPretype c -> TacPretype (intern_constr ist c) + | TacNumgoals -> TacNumgoals + | Tacexp t -> Tacexp (intern_tactic onlytac ist t) + | TacGeneric arg -> + let arg = intern_genarg ist arg in + TacGeneric arg + +(* Reads the rules of a Match Context or a Match *) +and intern_match_rule onlytac ist ?(as_type=false) = function + | (All tc)::tl -> + All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist ~as_type tl) + | (Pat (rl,mp,tc))::tl -> + let {ltacvars=lfun; genv=env} = ist in + let lfun',metas1,hyps = intern_match_goal_hyps ist ~as_type lfun rl in + let ido,metas2,pat = intern_pattern ist ~as_type lfun mp in + let fold accu x = Id.Set.add x accu in + let ltacvars = List.fold_left fold (opt_cons lfun' ido) metas1 in + let ltacvars = List.fold_left fold ltacvars metas2 in + let ist' = { ist with ltacvars } in + Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist ~as_type tl) + | [] -> [] + +and intern_genarg ist (GenArg (Rawwit wit, x)) = + match wit with + | ListArg wit -> + let map x = + let ans = intern_genarg ist (in_gen (rawwit wit) x) in + out_gen (glbwit wit) ans + in + in_gen (glbwit (wit_list wit)) (List.map map x) + | OptArg wit -> + let ans = match x with + | None -> in_gen (glbwit (wit_opt wit)) None + | Some x -> + let s = out_gen (glbwit wit) (intern_genarg ist (in_gen (rawwit wit) x)) in + in_gen (glbwit (wit_opt wit)) (Some s) + in + ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = out_gen (glbwit wit1) (intern_genarg ist (in_gen (rawwit wit1) p)) in + let q = out_gen (glbwit wit2) (intern_genarg ist (in_gen (rawwit wit2) q)) in + in_gen (glbwit (wit_pair wit1 wit2)) (p, q) + | ExtraArg s -> + snd (Genintern.generic_intern ist (in_gen (rawwit wit) x)) + +(** Other entry points *) + +let glob_tactic x = + Flags.with_option strict_check + (intern_pure_tactic (make_empty_glob_sign ())) x + +let glob_tactic_env l env x = + let ltacvars = + List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in + Flags.with_option strict_check + (intern_pure_tactic + { ltacvars; genv = env }) + x + +let split_ltac_fun = function + | TacFun (l,t) -> (l,t) + | t -> ([],t) + +let pr_ltac_fun_arg = function + | None -> spc () ++ str "_" + | Some id -> spc () ++ pr_id id + +let print_ltac id = + try + let kn = Nametab.locate_tactic id in + let entries = Tacenv.ltac_entries () in + let tac = KNmap.find kn entries in + let filter mp = + try Some (Nametab.shortest_qualid_of_module mp) + with Not_found -> None + in + let mods = List.map_filter filter tac.Tacenv.tac_redef in + let redefined = match mods with + | [] -> mt () + | mods -> + let redef = prlist_with_sep fnl pr_qualid mods in + fnl () ++ str "Redefined by:" ++ fnl () ++ redef + in + let l,t = split_ltac_fun tac.Tacenv.tac_body in + hv 2 ( + hov 2 (str "Ltac" ++ spc() ++ pr_qualid id ++ + prlist pr_ltac_fun_arg l ++ spc () ++ str ":=") + ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) ++ redefined + with + Not_found -> + user_err ~hdr:"print_ltac" + (pr_qualid id ++ spc() ++ str "is not a user defined tactic.") + +(** Registering *) + +let lift intern = (); fun ist x -> (ist, intern ist x) + +let () = + let intern_intro_pattern ist pat = + let lf = ref Id.Set.empty in + let ans = intern_intro_pattern lf ist pat in + let ist = { ist with ltacvars = !lf } in + (ist, ans) + in + Genintern.register_intern0 wit_intro_pattern intern_intro_pattern + +let () = + let intern_clause ist cl = + let ans = clause_app (intern_hyp_location ist) cl in + (ist, ans) + in + Genintern.register_intern0 wit_clause_dft_concl intern_clause + +let intern_ident' ist id = + let lf = ref Id.Set.empty in + (ist, intern_ident lf ist id) + +let intern_ltac ist tac = + Flags.with_option strict_check (fun () -> intern_pure_tactic ist tac) () + +let () = + Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); + Genintern.register_intern0 wit_ref (lift intern_global_reference); + Genintern.register_intern0 wit_ident intern_ident'; + Genintern.register_intern0 wit_var (lift intern_hyp); + Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg); + Genintern.register_intern0 wit_ltac (lift intern_ltac); + Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis); + Genintern.register_intern0 wit_constr (fun ist c -> (ist,intern_constr ist c)); + Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c)); + Genintern.register_intern0 wit_open_constr (fun ist c -> (ist,intern_constr ist c)); + Genintern.register_intern0 wit_red_expr (lift intern_red_expr); + Genintern.register_intern0 wit_bindings (lift intern_bindings); + Genintern.register_intern0 wit_constr_with_bindings (lift intern_constr_with_bindings); + Genintern.register_intern0 wit_destruction_arg (lift intern_destruction_arg); + () + +(** Substitution for notations containing tactic-in-terms *) + +let notation_subst bindings tac = + let fold id c accu = + let loc = Glob_ops.loc_of_glob_constr (fst c) in + let c = ConstrMayEval (ConstrTerm c) in + ((loc, id), c) :: accu + in + let bindings = Id.Map.fold fold bindings [] in + (** This is theoretically not correct due to potential variable capture, but + Ltac has no true variables so one cannot simply substitute *) + TacLetIn (false, bindings, tac) + +let () = Genintern.register_ntn_subst0 wit_tactic notation_subst diff --git a/plugins/ltac/tacintern.mli b/plugins/ltac/tacintern.mli new file mode 100644 index 000000000..71ca354fa --- /dev/null +++ b/plugins/ltac/tacintern.mli @@ -0,0 +1,64 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* glob_sign + (** same as [fully_empty_glob_sign], but with [Global.env()] as + environment *) + +(** Main globalization functions *) + +val glob_tactic : raw_tactic_expr -> glob_tactic_expr + +val glob_tactic_env : + Id.t list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr + +(** Low-level variants *) + +val intern_pure_tactic : glob_sign -> raw_tactic_expr -> glob_tactic_expr + +val intern_tactic_or_tacarg : + glob_sign -> raw_tactic_expr -> Tacexpr.glob_tactic_expr + +val intern_constr : glob_sign -> constr_expr -> glob_constr_and_expr + +val intern_constr_with_bindings : + glob_sign -> constr_expr * constr_expr bindings -> + glob_constr_and_expr * glob_constr_and_expr bindings + +val intern_hyp : glob_sign -> Id.t Loc.located -> Id.t Loc.located + +(** Adds a globalization function for extra generic arguments *) + +val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument + +(** printing *) +val print_ltac : Libnames.qualid -> std_ppcmds + +(** Reduction expressions *) + +val intern_red_expr : glob_sign -> raw_red_expr -> glob_red_expr +val dump_glob_red_expr : raw_red_expr -> unit + +(* Hooks *) +val strict_check : bool ref diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml new file mode 100644 index 000000000..32bcdfb6a --- /dev/null +++ b/plugins/ltac/tacinterp.ml @@ -0,0 +1,2157 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* a typed_abstract_argument_type -> bool = fun v wit -> + let Val.Dyn (t, _) = v in + let t' = match val_tag wit with + | Val.Base t' -> t' + | _ -> assert false (** not used in this module *) + in + match Val.eq t t' with + | None -> false + | Some Refl -> true + +let prj : type a. a Val.typ -> Val.t -> a option = fun t v -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> None + | Some Refl -> Some x + +let in_list tag v = + let tag = match tag with Val.Base tag -> tag | _ -> assert false in + Val.Dyn (Val.typ_list, List.map (fun x -> Val.Dyn (tag, x)) v) +let in_gen wit v = + let t = match val_tag wit with + | Val.Base t -> t + | _ -> assert false (** not used in this module *) + in + Val.Dyn (t, v) +let out_gen wit v = + let t = match val_tag wit with + | Val.Base t -> t + | _ -> assert false (** not used in this module *) + in + match prj t v with None -> assert false | Some x -> x + +let val_tag wit = val_tag (topwit wit) + +let pr_argument_type arg = + let Val.Dyn (tag, _) = arg in + Val.pr tag + +let safe_msgnl s = + Proofview.NonLogical.catch + (Proofview.NonLogical.print_debug (s++fnl())) + (fun _ -> Proofview.NonLogical.print_warning (str "bug in the debugger: an exception is raised while printing debug information"++fnl())) + +type value = Val.t + +(** Abstract application, to print ltac functions *) +type appl = + | UnnamedAppl (** For generic applications: nothing is printed *) + | GlbAppl of (Names.kernel_name * Val.t list) list + (** For calls to global constants, some may alias other. *) +let push_appl appl args = + match appl with + | UnnamedAppl -> UnnamedAppl + | GlbAppl l -> GlbAppl (List.map (fun (h,vs) -> (h,vs@args)) l) +let pr_generic arg = + let Val.Dyn (tag, _) = arg in + str"<" ++ Val.pr tag ++ str ":(" ++ Pptactic.pr_value Pptactic.ltop arg ++ str ")>" +let pr_appl h vs = + Pptactic.pr_ltac_constant h ++ spc () ++ + Pp.prlist_with_sep spc pr_generic vs +let rec name_with_list appl t = + match appl with + | [] -> t + | (h,vs)::l -> Proofview.Trace.name_tactic (fun () -> pr_appl h vs) (name_with_list l t) +let name_if_glob appl t = + match appl with + | UnnamedAppl -> t + | GlbAppl l -> name_with_list l t +let combine_appl appl1 appl2 = + match appl1,appl2 with + | UnnamedAppl,a | a,UnnamedAppl -> a + | GlbAppl l1 , GlbAppl l2 -> GlbAppl (l2@l1) + +(* Values for interpretation *) +type tacvalue = + | VFun of appl*ltac_trace * value Id.Map.t * + Id.t option list * glob_tactic_expr + | VRec of value Id.Map.t ref * glob_tactic_expr + +let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = + let wit = Genarg.create_arg "tacvalue" in + let () = register_val0 wit None in + wit + +let of_tacvalue v = in_gen (topwit wit_tacvalue) v +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)) + | _ -> vle + else vle + +module TacStore = Geninterp.TacStore + +let f_avoid_ids : Id.t list TacStore.field = TacStore.field () +(* ids inherited from the call context (needed to get fresh ids) *) +let f_debug : debug_info TacStore.field = TacStore.field () +let f_trace : ltac_trace TacStore.field = TacStore.field () + +(* Signature for interpretation: val_interp and interpretation functions *) +type interp_sign = Geninterp.interp_sign = { + lfun : value Id.Map.t; + extra : TacStore.t } + +let extract_trace ist = match TacStore.get ist.extra f_trace with +| None -> [] +| Some l -> l + +module Value = struct + + include Taccoerce.Value + + let of_closure ist tac = + let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in + of_tacvalue closure + + let cast_error wit v = + let pr_v = Pptactic.pr_value Pptactic.ltop v in + let Val.Dyn (tag, _) = v in + let tag = Val.pr tag in + user_err (str "Type error: value " ++ pr_v ++ str " is a " ++ tag + ++ str " while type " ++ Val.pr wit ++ str " was expected.") + + let unbox wit v ans = match ans with + | None -> cast_error wit v + | Some x -> x + + let rec prj : type a. a Val.tag -> Val.t -> a = fun tag v -> match tag with + | Val.List tag -> List.map (fun v -> prj tag v) (unbox Val.typ_list v (to_list v)) + | Val.Opt tag -> Option.map (fun v -> prj tag v) (unbox Val.typ_opt v (to_option v)) + | Val.Pair (tag1, tag2) -> + let (x, y) = unbox Val.typ_pair v (to_pair v) in + (prj tag1 x, prj tag2 y) + | Val.Base t -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> cast_error t v + | Some Refl -> x + + let rec tag_of_arg : type a b c. (a, b, c) genarg_type -> c Val.tag = fun wit -> match wit with + | ExtraArg _ -> val_tag wit + | ListArg t -> Val.List (tag_of_arg t) + | OptArg t -> Val.Opt (tag_of_arg t) + | PairArg (t1, t2) -> Val.Pair (tag_of_arg t1, tag_of_arg t2) + + let val_cast arg v = prj (tag_of_arg arg) v + + let cast (Topwit wit) v = val_cast wit v + +end + +let print_top_val env v = Pptactic.pr_value Pptactic.ltop v + +let dloc = Loc.ghost + +let catching_error call_trace fail (e, info) = + let inner_trace = + Option.default [] (Exninfo.get info ltac_trace_info) + in + if List.is_empty call_trace && List.is_empty inner_trace then fail (e, info) + else begin + assert (CErrors.noncritical e); (* preserved invariant *) + let new_trace = inner_trace @ call_trace in + let located_exc = (e, Exninfo.add info ltac_trace_info new_trace) in + fail located_exc + end + +let catch_error call_trace f x = + try f x + with e when CErrors.noncritical e -> + let e = CErrors.push e in + catching_error call_trace iraise e + +let catch_error_tac call_trace tac = + Proofview.tclORELSE + tac + (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e)) + +let curr_debug ist = match TacStore.get ist.extra f_debug with +| None -> DebugOff +| Some level -> level + +(** TODO: unify printing of generic Ltac values in case of coercion failure. *) + +(* Displays a value *) +let pr_value env v = + let v = Value.normalize v in + if has_type v (topwit wit_tacvalue) then str "a tactic" + else if has_type v (topwit wit_constr_context) then + let c = out_gen (topwit wit_constr_context) v in + match env with + | Some (env,sigma) -> pr_lconstr_env env sigma c + | _ -> str "a term" + else if has_type v (topwit wit_constr) then + let c = out_gen (topwit wit_constr) v in + match env with + | Some (env,sigma) -> pr_lconstr_env env sigma c + | _ -> str "a term" + else if has_type v (topwit wit_constr_under_binders) then + let c = out_gen (topwit wit_constr_under_binders) v in + match env with + | Some (env,sigma) -> pr_lconstr_under_binders_env env sigma c + | _ -> str "a term" + else + str "a value of type" ++ spc () ++ pr_argument_type v + +let pr_closure env ist body = + let pp_body = Pptactic.pr_glob_tactic env body in + let pr_sep () = fnl () in + let pr_iarg (id, arg) = + let arg = pr_argument_type arg in + hov 0 (pr_id id ++ spc () ++ str ":" ++ spc () ++ arg) + in + let pp_iargs = v 0 (prlist_with_sep pr_sep pr_iarg (Id.Map.bindings ist)) in + pp_body ++ fnl() ++ str "in environment " ++ fnl() ++ pp_iargs + +let pr_inspect env expr result = + let pp_expr = Pptactic.pr_glob_tactic env expr in + let pp_result = + if has_type result (topwit wit_tacvalue) then + match to_tacvalue result with + | VFun (_,_, ist, ul, b) -> + let body = if List.is_empty ul then b else (TacFun (ul, b)) in + str "a closure with body " ++ fnl() ++ pr_closure env ist body + | VRec (ist, body) -> + str "a recursive closure" ++ fnl () ++ pr_closure env !ist body + else + let pp_type = pr_argument_type result in + str "an object of type" ++ spc () ++ pp_type + in + pp_expr ++ fnl() ++ str "this is " ++ pp_result + +(* Transforms an id into a constr if possible, or fails with Not_found *) +let constr_of_id env id = + Term.mkVar (let _ = Environ.lookup_named id env in id) + +(** Generic arguments : table of interpretation functions *) + +(* Some of the code further down depends on the fact that push_trace does not modify sigma (the evar map) *) +let push_trace call ist = match TacStore.get ist.extra f_trace with +| None -> Proofview.tclUNIT [call] +| 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 + | VFun (appl,_,lfun,it,b) -> + let t = if List.is_empty it then b else TacFun (it,b) in + push_trace(loc,LtacVarCall (id,t)) ist >>= fun trace -> + let ans = VFun (appl,trace,lfun,it,b) in + Proofview.tclUNIT (of_tacvalue ans) + | _ -> Proofview.tclUNIT 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)) + | _ -> v + else 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 " ++ pr_id 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 + | VFun _ -> v + | _ -> fail () + else fail () + +let intro_pattern_of_ident id = (Loc.ghost, IntroNaming (IntroIdentifier id)) +let value_of_ident id = + in_gen (topwit wit_intro_pattern) (intro_pattern_of_ident id) + +let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 + +let extend_values_with_bindings (ln,lm) lfun = + let of_cub c = match c with + | [], c -> Value.of_constr c + | _ -> in_gen (topwit wit_constr_under_binders) c + in + (* For compatibility, bound variables are visible only if no other + binding of the same name exists *) + let accu = Id.Map.map value_of_ident ln in + let accu = lfun +++ accu in + Id.Map.fold (fun id c accu -> Id.Map.add id (of_cub c) accu) lm accu + +(***************************************************************************) +(* Evaluation/interpretation *) + +let is_variable env id = + Id.List.mem id (ids_of_named_context (Environ.named_context env)) + +(* Debug reference *) +let debug = ref DebugOff + +(* Sets the debugger mode *) +let set_debug pos = debug := pos + +(* Gives the state of debug *) +let get_debug () = !debug + +let debugging_step ist pp = match curr_debug ist with + | DebugOn lev -> + safe_msgnl (str "Level " ++ int lev ++ str": " ++ pp () ++ fnl()) + | _ -> Proofview.NonLogical.return () + +let debugging_exception_step ist signal_anomaly e pp = + let explain_exc = + if signal_anomaly then explain_logic_error + else explain_logic_error_no_anomaly in + debugging_step ist (fun () -> + pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e) + +let error_ltac_variable loc id env v s = + user_err ~loc (str "Ltac variable " ++ pr_id id ++ + strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ + strbrk "which cannot be coerced to " ++ str s ++ str".") + +(* Raise Not_found if not in interpretation sign *) +let try_interp_ltac_var coerce ist env (loc,id) = + let v = Id.Map.find id ist.lfun in + try coerce v with CannotCoerceTo s -> error_ltac_variable loc id env v s + +let interp_ltac_var coerce ist env locid = + try try_interp_ltac_var coerce ist env locid + with Not_found -> anomaly (str "Detected '" ++ Id.print (snd locid) ++ str "' as ltac var at interning time") + +let interp_ident ist env sigma id = + try try_interp_ltac_var (coerce_var_to_ident false env) ist (Some (env,sigma)) (dloc,id) + with Not_found -> id + +(* Interprets an optional identifier, bound or fresh *) +let interp_name ist env sigma = function + | Anonymous -> Anonymous + | Name id -> Name (interp_ident ist env sigma id) + +let interp_intro_pattern_var loc ist env sigma id = + try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some (env,sigma)) (loc,id) + with Not_found -> IntroNaming (IntroIdentifier id) + +let interp_intro_pattern_naming_var loc ist env sigma id = + try try_interp_ltac_var (coerce_to_intro_pattern_naming env) ist (Some (env,sigma)) (loc,id) + with Not_found -> IntroIdentifier id + +let interp_int ist locid = + try try_interp_ltac_var coerce_to_int ist None locid + with Not_found -> + user_err ~loc:(fst locid) ~hdr:"interp_int" + (str "Unbound variable " ++ pr_id (snd locid) ++ str".") + +let interp_int_or_var ist = function + | ArgVar locid -> interp_int ist locid + | ArgArg n -> n + +let interp_int_or_var_as_list ist = function + | ArgVar (_,id as locid) -> + (try coerce_to_int_or_var_list (Id.Map.find id ist.lfun) + with Not_found | CannotCoerceTo _ -> [ArgArg (interp_int ist locid)]) + | ArgArg n as x -> [x] + +let interp_int_or_var_list ist l = + List.flatten (List.map (interp_int_or_var_as_list ist) l) + +(* Interprets a bound variable (especially an existing hypothesis) *) +let interp_hyp ist env sigma (loc,id as locid) = + (* Look first in lfun for a value coercible to a variable *) + try try_interp_ltac_var (coerce_to_hyp env) ist (Some (env,sigma)) 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)) + +let interp_hyp_list_as_list ist env sigma (loc,id as x) = + try coerce_to_hyp_list env (Id.Map.find id ist.lfun) + with Not_found | CannotCoerceTo _ -> [interp_hyp ist env sigma x] + +let interp_hyp_list ist env sigma l = + List.flatten (List.map (interp_hyp_list_as_list ist env sigma) l) + +let interp_move_location ist env sigma = function + | MoveAfter id -> MoveAfter (interp_hyp ist env sigma id) + | MoveBefore id -> MoveBefore (interp_hyp ist env sigma id) + | MoveFirst -> MoveFirst + | MoveLast -> MoveLast + +let interp_reference ist env sigma = function + | ArgArg (_,r) -> r + | ArgVar (loc, id) -> + try try_interp_ltac_var (coerce_to_reference env) ist (Some (env,sigma)) (loc, id) + with Not_found -> + try + VarRef (get_id (Environ.lookup_named id env)) + with Not_found -> error_global_not_found ~loc (qualid_of_ident id) + +let try_interp_evaluable env (loc, id) = + let v = Environ.lookup_named id env in + match v with + | LocalDef _ -> EvalVarRef id + | _ -> error_not_evaluable (VarRef id) + +let interp_evaluable ist env sigma = function + | ArgArg (r,Some (loc,id)) -> + (* Maybe [id] has been introduced by Intro-like tactics *) + begin + try try_interp_evaluable env (loc, id) + with Not_found -> + match r with + | EvalConstRef _ -> r + | _ -> error_global_not_found ~loc (qualid_of_ident id) + end + | ArgArg (r,None) -> r + | ArgVar (loc, id) -> + try try_interp_ltac_var (coerce_to_evaluable_ref env) ist (Some (env,sigma)) (loc, id) + with Not_found -> + try try_interp_evaluable env (loc, id) + with Not_found -> error_global_not_found ~loc (qualid_of_ident id) + +(* Interprets an hypothesis name *) +let interp_occurrences ist occs = + Locusops.occurrences_map (interp_int_or_var_list ist) occs + +let interp_hyp_location ist env sigma ((occs,id),hl) = + ((interp_occurrences ist occs,interp_hyp ist env sigma id),hl) + +let interp_hyp_location_list_as_list ist env sigma ((occs,id),hl as x) = + match occs,hl with + | AllOccurrences,InHyp -> + List.map (fun id -> ((AllOccurrences,id),InHyp)) + (interp_hyp_list_as_list ist env sigma id) + | _,_ -> [interp_hyp_location ist env sigma x] + +let interp_hyp_location_list ist env sigma l = + List.flatten (List.map (interp_hyp_location_list_as_list ist env sigma) l) + +let interp_clause ist env sigma { onhyps=ol; concl_occs=occs } : clause = + { onhyps=Option.map (interp_hyp_location_list ist env sigma) ol; + concl_occs=interp_occurrences ist occs } + +(* Interpretation of constructions *) + +(* Extract the constr list from lfun *) +let extract_ltac_constr_values ist env = + let fold id v accu = + try + let c = coerce_to_constr env v in + Id.Map.add id c accu + with CannotCoerceTo _ -> accu + in + Id.Map.fold fold ist.lfun Id.Map.empty +(** ppedrot: I have changed the semantics here. Before this patch, closure was + implemented as a list and a variable could be bound several times with + different types, resulting in its possible appearance on both sides. This + could barely be defined as a feature... *) + +(* Extract the identifier list from lfun: join all branches (what to do else?)*) +let rec intropattern_ids (loc,pat) = match pat with + | IntroNaming (IntroIdentifier id) -> [id] + | IntroAction (IntroOrAndPattern (IntroAndPattern l)) -> + List.flatten (List.map intropattern_ids l) + | IntroAction (IntroOrAndPattern (IntroOrPattern ll)) -> + List.flatten (List.map intropattern_ids (List.flatten ll)) + | IntroAction (IntroInjection l) -> + List.flatten (List.map intropattern_ids l) + | IntroAction (IntroApplyOn (c,pat)) -> intropattern_ids pat + | IntroNaming (IntroAnonymous | IntroFresh _) + | IntroAction (IntroWildcard | IntroRewrite _) + | IntroForthcoming _ -> [] + +let extract_ids ids lfun = + 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 + else accu @ intropattern_ids (dloc, ipat) + else accu + in + Id.Map.fold fold lfun [] + +let default_fresh_id = Id.of_string "H" + +let interp_fresh_id ist env sigma l = + let extract_ident ist env sigma id = + try try_interp_ltac_var (coerce_to_ident_not_fresh sigma env) + ist (Some (env,sigma)) (dloc,id) + with Not_found -> id in + let ids = List.map_filter (function ArgVar (_, id) -> Some id | _ -> None) l in + let avoid = match TacStore.get ist.extra f_avoid_ids with + | None -> [] + | Some l -> l + in + let avoid = (extract_ids ids ist.lfun) @ avoid in + let id = + if List.is_empty l then default_fresh_id + else + let s = + String.concat "" (List.map (function + | ArgArg s -> s + | ArgVar (_,id) -> Id.to_string (extract_ident ist env sigma id)) l) in + let s = if CLexer.is_keyword s then s^"0" else s in + Id.of_string s in + Tactics.fresh_id_in_env avoid id env + +(* Extract the uconstr list from lfun *) +let extract_ltac_constr_context ist env = + let open Glob_term in + let add_uconstr id env v map = + try Id.Map.add id (coerce_to_uconstr env v) map + with CannotCoerceTo _ -> map + in + let add_constr id env v map = + try Id.Map.add id (coerce_to_constr env v) map + with CannotCoerceTo _ -> map + in + let add_ident id env v map = + try Id.Map.add id (coerce_var_to_ident false env v) map + with CannotCoerceTo _ -> map + in + let fold id v {idents;typed;untyped} = + let idents = add_ident id env v idents in + let typed = add_constr id env v typed in + let untyped = add_uconstr id env v untyped in + { idents ; typed ; untyped } + in + let empty = { idents = Id.Map.empty ;typed = Id.Map.empty ; untyped = Id.Map.empty } in + Id.Map.fold fold ist.lfun empty + +(** Significantly simpler than [interp_constr], to interpret an + untyped constr, it suffices to adjoin a closure environment. *) +let interp_uconstr ist env = function + | (term,None) -> + { closure = extract_ltac_constr_context ist env ; term } + | (_,Some ce) -> + let ( {typed ; untyped } as closure) = extract_ltac_constr_context ist env in + let ltacvars = { + Constrintern.ltac_vars = Id.(Set.union (Map.domain typed) (Map.domain untyped)); + ltac_bound = Id.Map.domain ist.lfun; + } in + { closure ; term = intern_gen WithoutTypeConstraint ~ltacvars env ce } + +let interp_gen kind ist allow_patvar flags env sigma (c,ce) = + let constrvars = extract_ltac_constr_context ist env in + let vars = { + Pretyping.ltac_constrs = constrvars.typed; + Pretyping.ltac_uconstrs = constrvars.untyped; + Pretyping.ltac_idents = constrvars.idents; + Pretyping.ltac_genargs = ist.lfun; + } in + let c = match ce with + | None -> c + (* If at toplevel (ce<>None), the error can be due to an incorrect + context at globalization time: we retype with the now known + intros/lettac/inversion hypothesis names *) + | Some c -> + let constr_context = + Id.Set.union + (Id.Map.domain constrvars.typed) + (Id.Set.union + (Id.Map.domain constrvars.untyped) + (Id.Map.domain constrvars.idents)) + in + let ltacvars = { + ltac_vars = constr_context; + ltac_bound = Id.Map.domain ist.lfun; + } in + let kind_for_intern = + match kind with OfType _ -> WithoutTypeConstraint | _ -> kind in + intern_gen kind_for_intern ~allow_patvar ~ltacvars env c + in + (* Jason Gross: To avoid unnecessary modifications to tacinterp, as + suggested by Arnaud Spiwack, we run push_trace immediately. We do + this with the kludge of an empty proofview, and rely on the + invariant that running the tactic returned by push_trace does + not modify sigma. *) + let (_, dummy_proofview) = Proofview.init sigma [] in + let (trace,_,_,_) = Proofview.apply env (push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist) dummy_proofview in + let (evd,c) = + catch_error trace (understand_ltac flags env sigma vars kind) c + in + (* spiwack: to avoid unnecessary modifications of tacinterp, as this + function already use effect, I call [run] hoping it doesn't mess + up with any assumption. *) + Proofview.NonLogical.run (db_constr (curr_debug ist) env c); + (evd,c) + +let constr_flags = { + use_typeclasses = true; + solve_unification_constraints = true; + use_hook = Some solve_by_implicit_tactic; + fail_evar = true; + expand_evars = true } + +(* Interprets a constr; expects evars to be solved *) +let interp_constr_gen kind ist env sigma c = + interp_gen kind ist false constr_flags env sigma c + +let interp_constr = interp_constr_gen WithoutTypeConstraint + +let interp_type = interp_constr_gen IsType + +let open_constr_use_classes_flags = { + use_typeclasses = true; + solve_unification_constraints = true; + use_hook = Some solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true } + +let open_constr_no_classes_flags = { + use_typeclasses = false; + solve_unification_constraints = true; + use_hook = Some solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true } + +let pure_open_constr_flags = { + use_typeclasses = false; + solve_unification_constraints = true; + use_hook = None; + fail_evar = false; + expand_evars = false } + +(* Interprets an open constr *) +let interp_open_constr ?(expected_type=WithoutTypeConstraint) ist = + let flags = + if expected_type == WithoutTypeConstraint then open_constr_no_classes_flags + else open_constr_use_classes_flags in + interp_gen expected_type ist false flags + +let interp_pure_open_constr ist = + interp_gen WithoutTypeConstraint ist false pure_open_constr_flags + +let interp_typed_pattern ist env sigma (_,c,_) = + let sigma, c = + interp_gen WithoutTypeConstraint ist true pure_open_constr_flags env sigma c in + pattern_of_constr env sigma c + +(* Interprets a constr expression *) +let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = + let try_expand_ltac_var sigma x = + try match dest_fun x with + | GVar (_,id), _ -> + let v = Id.Map.find id ist.lfun in + sigma, List.map inj_fun (coerce_to_constr_list env v) + | _ -> + raise Not_found + with CannotCoerceTo _ | Not_found -> + (* dest_fun, List.assoc may raise Not_found *) + let sigma, c = interp_fun ist env sigma x in + sigma, [c] in + let sigma, l = List.fold_map try_expand_ltac_var sigma l in + sigma, List.flatten l + +let interp_constr_list ist env sigma c = + interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_constr ist env sigma c + +let interp_open_constr_list = + interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_open_constr + +(* Interprets a reduction expression *) +let interp_unfold ist env sigma (occs,qid) = + (interp_occurrences ist occs,interp_evaluable ist env sigma qid) + +let interp_flag ist env sigma red = + { red with rConst = List.map (interp_evaluable ist env sigma) red.rConst } + +let interp_constr_with_occurrences ist env sigma (occs,c) = + let (sigma,c_interp) = interp_constr ist env sigma c in + sigma , (interp_occurrences ist occs, c_interp) + +let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = + let p = match a with + | Inl (ArgVar (loc,id)) -> + (* This is the encoding of an ltac var supposed to be bound + prioritary to an evaluable reference and otherwise to a constr + (it is an encoding to satisfy the "union" type given to Simpl) *) + let coerce_eval_ref_or_constr x = + try Inl (coerce_to_evaluable_ref env x) + with CannotCoerceTo _ -> + let c = coerce_to_closed_constr env x in + Inr (pattern_of_constr env sigma c) in + (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (loc,id) + with Not_found -> + error_global_not_found ~loc (qualid_of_ident id)) + | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) + | Inr c -> Inr (interp_typed_pattern ist env sigma c) in + interp_occurrences ist occs, p + +let interp_constr_with_occurrences_and_name_as_list = + interp_constr_in_compound_list + (fun c -> ((AllOccurrences,c),Anonymous)) + (function ((occs,c),Anonymous) when occs == AllOccurrences -> c + | _ -> raise Not_found) + (fun ist env sigma (occ_c,na) -> + let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma occ_c in + sigma, (c_interp, + interp_name ist env sigma na)) + +let interp_red_expr ist env sigma = function + | Unfold l -> sigma , Unfold (List.map (interp_unfold ist env sigma) l) + | Fold l -> + let (sigma,l_interp) = interp_constr_list ist env sigma l in + sigma , Fold l_interp + | Cbv f -> sigma , Cbv (interp_flag ist env sigma f) + | Cbn f -> sigma , Cbn (interp_flag ist env sigma f) + | Lazy f -> sigma , Lazy (interp_flag ist env sigma f) + | Pattern l -> + let (sigma,l_interp) = + Evd.MonadR.List.map_right + (fun c sigma -> interp_constr_with_occurrences ist env sigma c) l sigma + in + sigma , Pattern l_interp + | Simpl (f,o) -> + sigma , Simpl (interp_flag ist env sigma f, + Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) + | CbvVm o -> + sigma , CbvVm (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) + | CbvNative o -> + sigma , CbvNative (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) + | (Red _ | Hnf | ExtraRedExpr _ as r) -> sigma , r + +let interp_may_eval f ist env sigma = function + | ConstrEval (r,c) -> + let (sigma,redexp) = interp_red_expr ist env sigma r in + let (sigma,c_interp) = f ist env sigma c in + let (redfun, _) = Redexpr.reduction_of_red_expr env redexp in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (c, sigma, _) = redfun.Reductionops.e_redfun env sigma c_interp in + (Sigma.to_evar_map sigma, c) + | ConstrContext ((loc,s),c) -> + (try + let (sigma,ic) = f ist env sigma c in + let ctxt = coerce_to_constr_context (Id.Map.find s ist.lfun) in + let evdref = ref sigma in + let c = subst_meta [Constr_matching.special_meta,ic] ctxt in + let c = Typing.e_solve_evars env evdref c in + !evdref , c + with + | Not_found -> + user_err ~loc ~hdr:"interp_may_eval" + (str "Unbound context identifier" ++ pr_id s ++ str".")) + | ConstrTypeOf c -> + let (sigma,c_interp) = f ist env sigma c in + Typing.type_of ~refresh:true env sigma c_interp + | ConstrTerm c -> + try + f ist env sigma c + with reraise -> + let reraise = CErrors.push reraise in + (* spiwack: to avoid unnecessary modifications of tacinterp, as this + function already use effect, I call [run] hoping it doesn't mess + up with any assumption. *) + Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> + str"interpretation of term " ++ pr_glob_constr_env env (fst c))); + iraise reraise + +(* Interprets a constr expression possibly to first evaluate *) +let interp_constr_may_eval ist env sigma c = + let (sigma,csr) = + try + interp_may_eval interp_constr ist env sigma c + with reraise -> + let reraise = CErrors.push reraise in + (* spiwack: to avoid unnecessary modifications of tacinterp, as this + function already use effect, I call [run] hoping it doesn't mess + up with any assumption. *) + Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> str"evaluation of term")); + iraise reraise + in + begin + (* spiwack: to avoid unnecessary modifications of tacinterp, as this + function already use effect, I call [run] hoping it doesn't mess + up with any assumption. *) + Proofview.NonLogical.run (db_constr (curr_debug ist) env csr); + sigma , csr + end + +(** TODO: should use dedicated printers *) +let rec message_of_value v = + let v = Value.normalize v in + let open Ftactic in + if has_type v (topwit wit_tacvalue) then + Ftactic.return (str "") + else if has_type v (topwit wit_constr) then + let v = out_gen (topwit wit_constr) v in + Ftactic.nf_enter {enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (project gl) v) end } + else if has_type v (topwit wit_constr_under_binders) then + let c = out_gen (topwit wit_constr_under_binders) v in + Ftactic.nf_enter { enter = begin fun gl -> + Ftactic.return (pr_constr_under_binders_env (pf_env gl) (project gl) c) + end } + else if has_type v (topwit wit_unit) then + Ftactic.return (str "()") + else if has_type v (topwit wit_int) then + Ftactic.return (int (out_gen (topwit wit_int) v)) + else if has_type v (topwit wit_intro_pattern) then + let p = out_gen (topwit wit_intro_pattern) v in + let print env sigma c = pr_constr_env env sigma (fst (Tactics.run_delayed env Evd.empty c)) in + Ftactic.nf_enter { enter = begin fun gl -> + Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (project gl) c) p) + end } + else if has_type v (topwit wit_constr_context) then + let c = out_gen (topwit wit_constr_context) v in + Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (project gl) c) end } + else if has_type v (topwit wit_uconstr) then + let c = out_gen (topwit wit_uconstr) v in + Ftactic.nf_enter { enter = begin fun gl -> + Ftactic.return (pr_closed_glob_env (pf_env gl) + (project gl) c) + end } + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_id id) end } + else match Value.to_list v with + | Some l -> + Ftactic.List.map message_of_value l >>= fun l -> + Ftactic.return (prlist_with_sep spc (fun x -> x) l) + | None -> + let tag = pr_argument_type v in + Ftactic.return (str "<" ++ tag ++ str ">") (** TODO *) + +let interp_message_token ist = function + | MsgString s -> Ftactic.return (str s) + | MsgInt n -> Ftactic.return (int n) + | MsgIdent (loc,id) -> + let v = try Some (Id.Map.find id ist.lfun) with Not_found -> None in + match v with + | None -> Ftactic.lift (Tacticals.New.tclZEROMSG (pr_id id ++ str" not found.")) + | Some v -> message_of_value v + +let interp_message ist l = + let open Ftactic in + Ftactic.List.map (interp_message_token ist) l >>= fun l -> + Ftactic.return (prlist_with_sep spc (fun x -> x) l) + +let rec interp_intro_pattern ist env sigma = function + | loc, IntroAction pat -> + let (sigma,pat) = interp_intro_pattern_action ist env sigma pat in + sigma, (loc, IntroAction pat) + | loc, IntroNaming (IntroIdentifier id) -> + sigma, (loc, interp_intro_pattern_var loc ist env sigma id) + | loc, IntroNaming pat -> + sigma, (loc, IntroNaming (interp_intro_pattern_naming loc ist env sigma pat)) + | loc, IntroForthcoming _ as x -> sigma, x + +and interp_intro_pattern_naming loc ist env sigma = function + | IntroFresh id -> IntroFresh (interp_ident ist env sigma id) + | IntroIdentifier id -> interp_intro_pattern_naming_var loc ist env sigma id + | IntroAnonymous as x -> x + +and interp_intro_pattern_action ist env sigma = function + | IntroOrAndPattern l -> + let (sigma,l) = interp_or_and_intro_pattern ist env sigma l in + sigma, IntroOrAndPattern l + | IntroInjection l -> + let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in + sigma, IntroInjection l + | IntroApplyOn (c,ipat) -> + let c = { delayed = fun env sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_open_constr ist env sigma c in + Sigma.Unsafe.of_pair (c, sigma) + } in + let sigma,ipat = interp_intro_pattern ist env sigma ipat in + sigma, IntroApplyOn (c,ipat) + | IntroWildcard | IntroRewrite _ as x -> sigma, x + +and interp_or_and_intro_pattern ist env sigma = function + | IntroAndPattern l -> + let sigma, l = List.fold_map (interp_intro_pattern ist env) sigma l in + sigma, IntroAndPattern l + | IntroOrPattern ll -> + let sigma, ll = List.fold_map (interp_intro_pattern_list_as_list ist env) sigma ll in + sigma, IntroOrPattern ll + +and interp_intro_pattern_list_as_list ist env sigma = function + | [loc,IntroNaming (IntroIdentifier id)] as l -> + (try sigma, coerce_to_intro_pattern_list loc env (Id.Map.find id ist.lfun) + with Not_found | CannotCoerceTo _ -> + List.fold_map (interp_intro_pattern ist env) sigma l) + | l -> List.fold_map (interp_intro_pattern ist env) sigma l + +let interp_intro_pattern_naming_option ist env sigma = function + | None -> None + | Some (loc,pat) -> Some (loc, interp_intro_pattern_naming loc ist env sigma pat) + +let interp_or_and_intro_pattern_option ist env sigma = function + | None -> sigma, None + | Some (ArgVar (loc,id)) -> + (match coerce_to_intro_pattern env (Id.Map.find id ist.lfun) with + | IntroAction (IntroOrAndPattern l) -> sigma, Some (loc,l) + | _ -> + user_err ~loc (str "Cannot coerce to a disjunctive/conjunctive pattern.")) + | Some (ArgArg (loc,l)) -> + let sigma,l = interp_or_and_intro_pattern ist env sigma l in + sigma, Some (loc,l) + +let interp_intro_pattern_option ist env sigma = function + | None -> sigma, None + | Some ipat -> + let sigma, ipat = interp_intro_pattern ist env sigma ipat in + sigma, Some ipat + +let interp_in_hyp_as ist env sigma (id,ipat) = + let sigma, ipat = interp_intro_pattern_option ist env sigma ipat in + sigma,(interp_hyp ist env sigma id,ipat) + +let interp_quantified_hypothesis ist = function + | AnonHyp n -> AnonHyp n + | NamedHyp id -> + try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id) + with Not_found -> NamedHyp id + +let interp_binding_name ist = function + | AnonHyp n -> AnonHyp n + | NamedHyp id -> + (* If a name is bound, it has to be a quantified hypothesis *) + (* user has to use other names for variables if these ones clash with *) + (* a name intented to be used as a (non-variable) identifier *) + try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id) + with Not_found -> NamedHyp id + +let interp_declared_or_quantified_hypothesis ist env sigma = function + | AnonHyp n -> AnonHyp n + | NamedHyp id -> + try try_interp_ltac_var + (coerce_to_decl_or_quant_hyp env) ist (Some (env,sigma)) (dloc,id) + with Not_found -> NamedHyp id + +let interp_binding ist env sigma (loc,b,c) = + let sigma, c = interp_open_constr ist env sigma c in + sigma, (loc,interp_binding_name ist b,c) + +let interp_bindings ist env sigma = function +| NoBindings -> + sigma, NoBindings +| ImplicitBindings l -> + let sigma, l = interp_open_constr_list ist env sigma l in + sigma, ImplicitBindings l +| ExplicitBindings l -> + let sigma, l = List.fold_map (interp_binding ist env) sigma l in + sigma, ExplicitBindings l + +let interp_constr_with_bindings ist env sigma (c,bl) = + let sigma, bl = interp_bindings ist env sigma bl in + let sigma, c = interp_open_constr ist env sigma c in + sigma, (c,bl) + +let interp_open_constr_with_bindings ist env sigma (c,bl) = + let sigma, bl = interp_bindings ist env sigma bl in + let sigma, c = interp_open_constr ist env sigma c in + sigma, (c, bl) + +let loc_of_bindings = function +| NoBindings -> Loc.ghost +| ImplicitBindings l -> loc_of_glob_constr (fst (List.last l)) +| ExplicitBindings l -> pi1 (List.last l) + +let interp_open_constr_with_bindings_loc ist ((c,_),bl as cb) = + let loc1 = loc_of_glob_constr c in + let loc2 = loc_of_bindings bl in + let loc = if Loc.is_ghost loc2 then loc1 else Loc.merge loc1 loc2 in + let f = { delayed = fun env sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_open_constr_with_bindings ist env sigma cb in + Sigma.Unsafe.of_pair (c, sigma) + } in + (loc,f) + +let interp_destruction_arg ist gl arg = + match arg with + | keep,ElimOnConstr c -> + keep,ElimOnConstr { delayed = fun env sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_constr_with_bindings ist env sigma c in + Sigma.Unsafe.of_pair (c, sigma) + } + | keep,ElimOnAnonHyp n as x -> x + | keep,ElimOnIdent (loc,id) -> + let error () = user_err ~loc + (strbrk "Cannot coerce " ++ pr_id id ++ + strbrk " neither to a quantified hypothesis nor to a term.") + in + let try_cast_id id' = + if Tactics.is_quantified_hypothesis id' gl + then keep,ElimOnIdent (loc,id') + else + (keep, ElimOnConstr { delayed = begin fun env sigma -> + try Sigma.here (constr_of_id env id', NoBindings) sigma + with Not_found -> + user_err ~loc ~hdr:"interp_destruction_arg" ( + pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis.") + end }) + in + 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 + | _, IntroNaming (IntroIdentifier id) -> try_cast_id id + | _ -> error () + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + try_cast_id id + else if has_type v (topwit wit_int) then + keep,ElimOnAnonHyp (out_gen (topwit wit_int) v) + else match Value.to_constr v with + | None -> error () + | Some c -> keep,ElimOnConstr { delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) } + with Not_found -> + (* We were in non strict (interactive) mode *) + if Tactics.is_quantified_hypothesis id gl then + keep,ElimOnIdent (loc,id) + else + let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in + let f = { delayed = fun env sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma,c) = interp_open_constr ist env sigma c in + Sigma.Unsafe.of_pair ((c,NoBindings), sigma) + } in + keep,ElimOnConstr f + +(* Associates variables with values and gives the remaining variables and + values *) +let head_with_value (lvar,lval) = + let rec head_with_value_rec lacc = function + | ([],[]) -> (lacc,[],[]) + | (vr::tvr,ve::tve) -> + (match vr with + | None -> head_with_value_rec lacc (tvr,tve) + | Some v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve)) + | (vr,[]) -> (lacc,vr,[]) + | ([],ve) -> (lacc,[],ve) + in + head_with_value_rec [] (lvar,lval) + +(** [interp_context ctxt] interprets a context (as in + {!Matching.matching_result}) into a context value of Ltac. *) +let interp_context ctxt = in_gen (topwit wit_constr_context) ctxt + +(* Reads a pattern by substituting vars of lfun *) +let use_types = false + +let eval_pattern lfun ist env sigma (bvars,(glob,_),pat as c) = + if use_types then + (bvars,interp_typed_pattern ist env sigma c) + else + (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) + | Term c -> Term (eval_pattern lfun ist env sigma c) + +(* Reads the hypotheses of a Match Context rule *) +let cons_and_check_name id l = + if Id.List.mem id l then + user_err ~hdr:"read_match_goal_hyps" ( + str "Hypothesis pattern-matching variable " ++ pr_id id ++ + str " used twice in the same pattern.") + else id::l + +let rec read_match_goal_hyps lfun ist env sigma lidh = function + | (Hyp ((loc,na) as locna,mp))::tl -> + let lidh' = name_fold cons_and_check_name na lidh in + Hyp (locna,read_pattern lfun ist env sigma mp):: + (read_match_goal_hyps lfun ist env sigma lidh' tl) + | (Def ((loc,na) as locna,mv,mp))::tl -> + let lidh' = name_fold cons_and_check_name na lidh in + Def (locna,read_pattern lfun ist env sigma mv, read_pattern lfun ist env sigma mp):: + (read_match_goal_hyps lfun ist env sigma lidh' tl) + | [] -> [] + +(* Reads the rules of a Match Context or a Match *) +let rec read_match_rule lfun ist env sigma = function + | (All tc)::tl -> (All tc)::(read_match_rule lfun ist env sigma tl) + | (Pat (rl,mp,tc))::tl -> + Pat (read_match_goal_hyps lfun ist env sigma [] rl, read_pattern lfun ist env sigma mp,tc) + :: read_match_rule lfun ist env sigma tl + | [] -> [] + +let warn_deprecated_info = + CWarnings.create ~name:"deprecated-info-tactical" ~category:"deprecated" + (fun () -> + strbrk "The general \"info\" tactic is currently not working." ++ spc()++ + strbrk "There is an \"Info\" command to replace it." ++fnl () ++ + strbrk "Some specific verbose tactics may also exist, such as info_eauto.") + +(* Interprets an l-tac expression into a value *) +let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftactic.t = + (* The name [appl] of applied top-level Ltac names is ignored in + [value_interp]. It is installed in the second step by a call to + [name_vfun], because it gives more opportunities to detect a + [VFun]. Otherwise a [Ltac t := let x := .. in tac] would never + register its name since it is syntactically a let, not a + function. *) + let value_interp ist = match tac with + | TacFun (it, body) -> + Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, it, body))) + | TacLetIn (true,l,u) -> interp_letrec ist l u + | TacLetIn (false,l,u) -> interp_letin ist l u + | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist lz lr lmr + | TacMatch (lz,c,lmr) -> interp_match ist lz c lmr + | TacArg (loc,a) -> interp_tacarg ist a + | t -> + (** Delayed evaluation *) + Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], t))) + in + let open Ftactic in + Control.check_for_interrupt (); + match curr_debug ist with + | DebugOn lev -> + let eval v = + let ist = { ist with extra = TacStore.set ist.extra f_debug v } in + value_interp ist >>= fun v -> return (name_vfun appl v) + in + Tactic_debug.debug_prompt lev tac eval + | _ -> value_interp ist >>= fun v -> return (name_vfun appl v) + + +and eval_tactic ist tac : unit Proofview.tactic = match tac with + | TacAtom (loc,t) -> + let call = LtacAtomCall t in + push_trace(loc,call) ist >>= fun trace -> + Profile_ltac.do_profile "eval_tactic:2" trace + (catch_error_tac trace (interp_atomic ist t)) + | TacFun _ | TacLetIn _ -> assert false + | TacMatchGoal _ | TacMatch _ -> assert false + | TacId [] -> Proofview.tclLIFT (db_breakpoint (curr_debug ist) []) + | TacId s -> + let msgnl = + let open Ftactic in + interp_message ist s >>= fun msg -> + return (hov 0 msg , hov 0 msg) + in + let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print_info msgnl)) in + let log (msg,_) = Proofview.Trace.log (fun () -> msg) in + let break = Proofview.tclLIFT (db_breakpoint (curr_debug ist) s) in + Ftactic.run msgnl begin fun msgnl -> + print msgnl <*> log msgnl <*> break + end + | TacFail (g,n,s) -> + let msg = interp_message ist s in + let tac l = Tacticals.New.tclFAIL (interp_int_or_var ist n) l in + let tac = + match g with + | TacLocal -> fun l -> Proofview.tclINDEPENDENT (tac l) + | TacGlobal -> tac + in + Ftactic.run msg tac + | TacProgress tac -> Tacticals.New.tclPROGRESS (interp_tactic ist tac) + | TacShowHyps tac -> + Proofview.V82.tactic begin + tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac)) + end + | TacAbstract (tac,ido) -> + Proofview.Goal.nf_enter { enter = begin fun gl -> Tactics.tclABSTRACT + (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist tac) + end } + | TacThen (t1,t) -> + Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t) + | TacDispatch tl -> + Proofview.tclDISPATCH (List.map (interp_tactic ist) tl) + | TacExtendTac (tf,t,tl) -> + Proofview.tclEXTEND (Array.map_to_list (interp_tactic ist) tf) + (interp_tactic ist t) + (Array.map_to_list (interp_tactic ist) tl) + | TacThens (t1,tl) -> Tacticals.New.tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl) + | TacThens3parts (t1,tf,t,tl) -> + Tacticals.New.tclTHENS3PARTS (interp_tactic ist t1) + (Array.map (interp_tactic ist) tf) (interp_tactic ist t) (Array.map (interp_tactic ist) tl) + | TacDo (n,tac) -> Tacticals.New.tclDO (interp_int_or_var ist n) (interp_tactic ist tac) + | TacTimeout (n,tac) -> Tacticals.New.tclTIMEOUT (interp_int_or_var ist n) (interp_tactic ist tac) + | TacTime (s,tac) -> Tacticals.New.tclTIME s (interp_tactic ist tac) + | TacTry tac -> Tacticals.New.tclTRY (interp_tactic ist tac) + | TacRepeat tac -> Tacticals.New.tclREPEAT (interp_tactic ist tac) + | TacOr (tac1,tac2) -> + Tacticals.New.tclOR (interp_tactic ist tac1) (interp_tactic ist tac2) + | TacOnce tac -> + Tacticals.New.tclONCE (interp_tactic ist tac) + | TacExactlyOnce tac -> + Tacticals.New.tclEXACTLY_ONCE (interp_tactic ist tac) + | TacIfThenCatch (t,tt,te) -> + Tacticals.New.tclIFCATCH + (interp_tactic ist t) + (fun () -> interp_tactic ist tt) + (fun () -> interp_tactic ist te) + | TacOrelse (tac1,tac2) -> + Tacticals.New.tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2) + | TacFirst l -> Tacticals.New.tclFIRST (List.map (interp_tactic ist) l) + | TacSolve l -> Tacticals.New.tclSOLVE (List.map (interp_tactic ist) l) + | TacComplete tac -> Tacticals.New.tclCOMPLETE (interp_tactic ist tac) + | TacArg a -> interp_tactic ist (TacArg a) + | TacInfo tac -> + warn_deprecated_info (); + eval_tactic ist tac + | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac) + (* For extensions *) + | TacAlias (loc,s,l) -> + let (ids, body) = Tacenv.interp_alias s in + let (>>=) = Ftactic.bind in + let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in + let tac l = + let addvar x v accu = Id.Map.add x v accu in + let lfun = List.fold_right2 addvar ids l ist.lfun in + Ftactic.lift (push_trace (loc,LtacNotationCall s) ist) >>= fun trace -> + let ist = { + lfun = lfun; + extra = TacStore.set ist.extra f_trace trace; } in + val_interp ist body >>= fun v -> + Ftactic.lift (tactic_of_value ist v) + in + let tac = + Ftactic.with_env interp_vars >>= fun (env, lr) -> + let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in + Proofview.Trace.name_tactic name (tac lr) + (* spiwack: this use of name_tactic is not robust to a + change of implementation of [Ftactic]. In such a situation, + some more elaborate solution will have to be used. *) + in + let tac = + let len1 = List.length ids in + let len2 = List.length l in + if len1 = len2 then tac + else Tacticals.New.tclZEROMSG (str "Arguments length mismatch: \ + expected " ++ int len1 ++ str ", found " ++ int len2) + in + Ftactic.run tac (fun () -> Proofview.tclUNIT ()) + + | TacML (loc,opn,l) -> + push_trace (loc,LtacMLCall tac) ist >>= fun trace -> + let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in + let tac = Tacenv.interp_ml_tactic opn in + let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in + let tac args = + let name () = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in + Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) + in + 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 + | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} body + | v -> Ftactic.return (of_tacvalue v) + else Ftactic.return v + +and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t = + match r with + | ArgVar (loc,id) -> + let v = + try Id.Map.find id ist.lfun + with Not_found -> in_gen (topwit wit_var) id + in + let open Ftactic in + force_vrec ist v >>= begin fun v -> + Ftactic.lift (propagate_trace ist loc id v) >>= fun v -> + if mustbetac then Ftactic.return (coerce_to_tactic loc id v) else Ftactic.return v + end + | ArgArg (loc,r) -> + let ids = extract_ids [] ist.lfun in + let loc_info = ((if Loc.is_ghost loc' then loc else loc'),LtacNameCall r) in + let extra = TacStore.set ist.extra f_avoid_ids ids in + push_trace loc_info ist >>= fun trace -> + 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) + +and interp_tacarg ist arg : Val.t Ftactic.t = + match arg with + | TacGeneric arg -> interp_genarg ist arg + | Reference r -> interp_ltac_reference dloc false ist r + | ConstrMayEval c -> + Ftactic.s_enter { s_enter = begin fun gl -> + let sigma = project gl in + let env = Proofview.Goal.env gl in + let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in + Sigma.Unsafe.of_pair (Ftactic.return (Value.of_constr c_interp), sigma) + end } + | TacCall (loc,r,[]) -> + interp_ltac_reference loc true ist r + | TacCall (loc,f,l) -> + let (>>=) = Ftactic.bind in + interp_ltac_reference loc true ist f >>= fun fv -> + Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs -> + interp_app loc ist fv largs + | TacFreshId l -> + Ftactic.enter { enter = begin fun gl -> + let id = interp_fresh_id ist (pf_env gl) (project gl) l in + Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id))) + end } + | TacPretype c -> + Ftactic.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let c = interp_uconstr ist env c in + let Sigma (c, sigma, p) = (type_uconstr ist c).delayed env sigma in + Sigma (Ftactic.return (Value.of_constr c), sigma, p) + end } + | TacNumgoals -> + Ftactic.lift begin + let open Proofview.Notations in + Proofview.numgoals >>= fun i -> + Proofview.tclUNIT (Value.of_int i) + end + | Tacexp t -> val_interp ist t + +(* Interprets an application node *) +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 + is not a tactic that expects arguments. + Otherwise Ltac goes into an infinite loop (val_interp puts + a VFun back on body, and then interp_app is called again...) *) + | (VFun(appl,trace,olfun,(_::_ as var),body) + |VFun(appl,trace,olfun,([] as var), + (TacFun _|TacLetIn _|TacMatchGoal _|TacMatch _| TacArg _ as body))) -> + let (extfun,lvar,lval)=head_with_value (var,largs) in + let fold accu (id, v) = Id.Map.add id v accu in + let newlfun = List.fold_left fold olfun extfun in + if List.is_empty lvar then + begin Proofview.tclORELSE + begin + let ist = { + lfun = newlfun; + extra = TacStore.set ist.extra f_trace []; } in + catch_error_tac trace (val_interp ist body) >>= fun v -> + Ftactic.return (name_vfun (push_appl appl largs) v) + end + begin fun (e, info) -> + Proofview.tclLIFT (debugging_exception_step ist false e (fun () -> str "evaluation")) <*> + Proofview.tclZERO ~info e + end + end >>= fun v -> + (* No errors happened, we propagate the trace *) + let v = append_trace trace v in + Proofview.tclLIFT begin + debugging_step ist + (fun () -> + str"evaluation returns"++fnl()++pr_value None v) + end <*> + if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval + else + Ftactic.return (of_tacvalue (VFun(push_appl appl largs,trace,newlfun,lvar,body))) + | _ -> fail + else fail + +(* 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) -> + let ist = { + lfun = lfun; + 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 _|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 + tactic_of_value ist tac + else Tacticals.New.tclZEROMSG (str "Expression does not evaluate to a tactic.") + +(* Interprets the clauses of a recursive LetIn *) +and interp_letrec ist llc u = + Proofview.tclUNIT () >>= fun () -> (* delay for the effects of [lref], just in case. *) + let lref = ref ist.lfun in + let fold accu ((_, id), b) = + let v = of_tacvalue (VRec (lref, TacArg (dloc, b))) in + Id.Map.add id v accu + in + let lfun = List.fold_left fold ist.lfun llc in + let () = lref := lfun in + let ist = { ist with lfun } in + val_interp ist u + +(* Interprets the clauses of a LetIn *) +and interp_letin ist llc u = + let rec fold lfun = function + | [] -> + let ist = { ist with lfun } in + val_interp ist u + | ((_, id), body) :: defs -> + Ftactic.bind (interp_tacarg ist body) (fun v -> + fold (Id.Map.add id v lfun) defs) + in + fold ist.lfun llc + +(** [interp_match_success lz ist succ] interprets a single matching success + (of type {!Tactic_matching.t}). *) +and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = + let (>>=) = Ftactic.bind in + let lctxt = Id.Map.map interp_context context in + let hyp_subst = Id.Map.map Value.of_constr terms in + let lfun = extend_values_with_bindings subst (lctxt +++ hyp_subst +++ ist.lfun) in + let ist = { ist with lfun } in + val_interp ist lhs >>= fun v -> + if has_type v (topwit wit_tacvalue) then match to_tacvalue v with + | VFun (appl,trace,lfun,[],t) -> + let ist = { + lfun = lfun; + extra = TacStore.set ist.extra f_trace trace; } in + let tac = eval_tactic ist t in + let dummy = VFun (appl,extract_trace ist, Id.Map.empty, [], TacId []) in + catch_error_tac trace (tac <*> Ftactic.return (of_tacvalue dummy)) + | _ -> Ftactic.return v + else Ftactic.return v + + +(** [interp_match_successes lz ist s] interprets the stream of + matching of successes [s]. If [lz] is set to true, then only the + first success is considered, otherwise further successes are tried + if the left-hand side fails. *) +and interp_match_successes lz ist s = + let general = + let break (e, info) = match e with + | FailError (0, _) -> None + | FailError (n, s) -> Some (FailError (pred n, s), info) + | _ -> None + in + Proofview.tclBREAK break s >>= fun ans -> interp_match_success ist ans + in + match lz with + | General -> + general + | Select -> + begin + (** Only keep the first matching result, we don't backtrack on it *) + let s = Proofview.tclONCE s in + s >>= fun ans -> interp_match_success ist ans + end + | Once -> + (** Once a tactic has succeeded, do not backtrack anymore *) + Proofview.tclONCE general + +(* Interprets the Match expressions *) +and interp_match ist lz constr lmr = + let (>>=) = Ftactic.bind in + begin Proofview.tclORELSE + (interp_ltac_constr ist constr) + begin function + | (e, info) -> + Proofview.tclLIFT (debugging_exception_step ist true e + (fun () -> str "evaluation of the matched expression")) <*> + Proofview.tclZERO ~info e + end + end >>= fun constr -> + Ftactic.enter { enter = begin fun gl -> + let sigma = project gl in + let env = Proofview.Goal.env gl in + let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in + interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr) + end } + +(* Interprets the Match Context expressions *) +and interp_match_goal ist lz lr lmr = + Ftactic.nf_enter { enter = begin fun gl -> + let sigma = project gl in + let env = Proofview.Goal.env gl in + let hyps = Proofview.Goal.hyps gl in + let hyps = if lr then List.rev hyps else hyps in + let concl = Proofview.Goal.concl gl in + let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in + interp_match_successes lz ist (Tactic_matching.match_goal env sigma hyps concl ilr) + end } + +(* Interprets extended tactic generic arguments *) +and interp_genarg ist x : Val.t Ftactic.t = + let open Ftactic.Notations in + (** Ad-hoc handling of some types. *) + let tag = genarg_tag x in + if argument_type_eq tag (unquote (topwit (wit_list wit_var))) then + interp_genarg_var_list ist x + else if argument_type_eq tag (unquote (topwit (wit_list wit_constr))) then + interp_genarg_constr_list ist x + else + let GenArg (Glbwit wit, x) = x in + match wit with + | ListArg wit -> + let map x = interp_genarg ist (Genarg.in_gen (glbwit wit) x) in + Ftactic.List.map map x >>= fun l -> + Ftactic.return (Val.Dyn (Val.typ_list, l)) + | OptArg wit -> + begin match x with + | None -> Ftactic.return (Val.Dyn (Val.typ_opt, None)) + | Some x -> + interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> + Ftactic.return (Val.Dyn (Val.typ_opt, Some x)) + end + | PairArg (wit1, wit2) -> + let (p, q) = x in + interp_genarg ist (Genarg.in_gen (glbwit wit1) p) >>= fun p -> + interp_genarg ist (Genarg.in_gen (glbwit wit2) q) >>= fun q -> + Ftactic.return (Val.Dyn (Val.typ_pair, (p, q))) + | ExtraArg s -> + Geninterp.interp wit ist x + +(** returns [true] for genargs which have the same meaning + independently of goals. *) + +and interp_genarg_constr_list ist x = + Ftactic.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in + let (sigma,lc) = interp_constr_list ist env sigma lc in + let lc = in_list (val_tag wit_constr) lc in + Sigma.Unsafe.of_pair (Ftactic.return lc, sigma) + end } + +and interp_genarg_var_list ist x = + Ftactic.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let lc = Genarg.out_gen (glbwit (wit_list wit_var)) x in + let lc = interp_hyp_list ist env sigma lc in + let lc = in_list (val_tag wit_var) lc in + Ftactic.return lc + end } + +(* Interprets tactic expressions : returns a "constr" *) +and interp_ltac_constr ist e : constr Ftactic.t = + let (>>=) = Ftactic.bind in + begin Proofview.tclORELSE + (val_interp ist e) + begin function (err, info) -> match err with + | Not_found -> + Ftactic.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + Proofview.tclLIFT begin + debugging_step ist (fun () -> + str "evaluation failed for" ++ fnl() ++ + Pptactic.pr_glob_tactic env e) + end + <*> Proofview.tclZERO Not_found + end } + | err -> Proofview.tclZERO ~info err + end + end >>= fun result -> + Ftactic.enter { 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 + debugging_step ist (fun () -> + Pptactic.pr_glob_tactic env e ++ fnl() ++ + str " has value " ++ fnl() ++ + pr_constr_env env sigma cresult) + end <*> + Ftactic.return cresult + with CannotCoerceTo _ -> + let env = Proofview.Goal.env gl in + Tacticals.New.tclZEROMSG (str "Must evaluate to a closed term" ++ fnl() ++ + str "offending expression: " ++ fnl() ++ pr_inspect env e result) + end } + + +(* Interprets tactic expressions : returns a "tactic" *) +and interp_tactic ist tac : unit Proofview.tactic = + Ftactic.run (val_interp ist tac) (fun v -> tactic_of_value ist v) + +(* Provides a "name" for the trace to atomic tactics *) +and name_atomic ?env tacexpr tac : unit Proofview.tactic = + begin match env with + | Some e -> Proofview.tclUNIT e + | None -> Proofview.tclENV + end >>= fun env -> + let name () = Pptactic.pr_atomic_tactic env tacexpr in + Proofview.Trace.name_tactic name tac + +(* Interprets a primitive tactic *) +and interp_atomic ist tac : unit Proofview.tactic = + match tac with + (* Basic tactics *) + | TacIntroPattern (ev,l) -> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in + Tacticals.New.tclWITHHOLES ev + (name_atomic ~env + (TacIntroPattern (ev,l)) + (* spiwack: print uninterpreted, not sure if it is the + expected behaviour. *) + (Tactics.intro_patterns ev l')) sigma + end } + | TacApply (a,ev,cb,cl) -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"") begin + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let l = List.map (fun (k,c) -> + let loc, f = interp_open_constr_with_bindings_loc ist c in + (k,(loc,f))) cb + in + let sigma,tac = match cl with + | None -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l + | Some cl -> + let sigma,(id,cl) = interp_in_hyp_as ist env sigma cl in + sigma, Tactics.apply_delayed_in a ev id l cl in + Tacticals.New.tclWITHHOLES ev tac sigma + end } + end + | TacElim (ev,(keep,cb),cbo) -> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let sigma, cb = interp_constr_with_bindings ist env sigma cb in + let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in + let named_tac = + let tac = Tactics.elim ev keep cb cbo in + name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac + in + Tacticals.New.tclWITHHOLES ev named_tac sigma + end } + | TacCase (ev,(keep,cb)) -> + Proofview.Goal.enter { enter = begin fun gl -> + let sigma = project gl in + let env = Proofview.Goal.env gl in + let sigma, cb = interp_constr_with_bindings ist env sigma cb in + let named_tac = + let tac = Tactics.general_case_analysis ev keep cb in + name_atomic ~env (TacCase(ev,(keep,cb))) tac + in + Tacticals.New.tclWITHHOLES ev named_tac sigma + end } + | TacMutualFix (id,n,l) -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"") begin + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let env = pf_env gl in + let f sigma (id,n,c) = + let (sigma,c_interp) = interp_type ist env sigma c in + sigma , (interp_ident ist env sigma id,n,c_interp) in + let (sigma,l_interp) = + Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) + in + let tac = Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0 in + Sigma.Unsafe.of_pair (tac, sigma) + end } + end + | TacMutualCofix (id,l) -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"") begin + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let env = pf_env gl in + let f sigma (id,c) = + let (sigma,c_interp) = interp_type ist env sigma c in + sigma , (interp_ident ist env sigma id,c_interp) in + let (sigma,l_interp) = + Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) + in + let tac = Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0 in + Sigma.Unsafe.of_pair (tac, sigma) + end } + end + | TacAssert (b,t,ipat,c) -> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let (sigma,c) = + (if Option.is_empty t then interp_constr else interp_type) ist env sigma c + in + let sigma, ipat' = interp_intro_pattern_option ist env sigma ipat in + let tac = Option.map (Option.map (interp_tactic ist)) t in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env + (TacAssert(b,Option.map (Option.map ignore) t,ipat,c)) + (Tactics.forward b tac ipat' c)) sigma + end } + | TacGeneralize cl -> + Proofview.Goal.enter { enter = begin fun gl -> + let sigma = project gl in + let env = Proofview.Goal.env gl in + let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env + (TacGeneralize cl) + (Tactics.generalize_gen cl)) sigma + end } + | TacLetTac (na,c,clp,b,eqpat) -> + Proofview.V82.nf_evar_goals <*> + Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let clp = interp_clause ist env sigma clp in + let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in + if Locusops.is_nowhere clp then + (* We try to fully-typecheck the term *) + let (sigma,c_interp) = interp_constr ist env sigma c in + let let_tac b na c cl eqpat = + let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in + let with_eq = if b then None else Some (true,id) in + Tactics.letin_tac with_eq na c None cl + in + let na = interp_name ist env sigma na in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env + (TacLetTac(na,c_interp,clp,b,eqpat)) + (let_tac b na c_interp clp eqpat)) sigma + else + (* We try to keep the pattern structure as much as possible *) + let let_pat_tac b na c cl eqpat = + let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in + let with_eq = if b then None else Some (true,id) in + Tactics.letin_pat_tac with_eq na c cl + in + let (sigma',c) = interp_pure_open_constr ist env sigma c in + name_atomic ~env + (TacLetTac(na,c,clp,b,eqpat)) + (Tacticals.New.tclWITHHOLES false (*in hope of a future "eset/epose"*) + (let_pat_tac b (interp_name ist env sigma na) + ((sigma,sigma'),c) clp eqpat) sigma') + end } + + (* Derived basic tactics *) + | TacInductionDestruct (isrec,ev,(l,el)) -> + (* spiwack: some unknown part of destruct needs the goal to be + prenormalised. *) + Proofview.V82.nf_evar_goals <*> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let sigma,l = + List.fold_map begin fun sigma (c,(ipato,ipats),cls) -> + (* TODO: move sigma as a side-effect *) + (* spiwack: the [*p] variants are for printing *) + let cp = c in + let c = interp_destruction_arg ist gl c in + let ipato = interp_intro_pattern_naming_option ist env sigma ipato in + let ipatsp = ipats in + let sigma,ipats = interp_or_and_intro_pattern_option ist env sigma ipats in + let cls = Option.map (interp_clause ist env sigma) cls in + sigma,((c,(ipato,ipats),cls),(cp,(ipato,ipatsp),cls)) + end sigma l + in + let l,lp = List.split l in + let sigma,el = + Option.fold_map (interp_constr_with_bindings ist env) sigma el in + let tac = name_atomic ~env + (TacInductionDestruct(isrec,ev,(lp,el))) + (Tactics.induction_destruct isrec ev (l,el)) + in + Sigma.Unsafe.of_pair (tac, sigma) + end } + + (* Conversion *) + | TacReduce (r,cl) -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in + Sigma.Unsafe.of_pair (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl), sigma) + end } + | TacChange (None,c,cl) -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"") begin + Proofview.V82.nf_evar_goals <*> + Proofview.Goal.nf_enter { enter = begin fun gl -> + let is_onhyps = match cl.onhyps with + | None | Some [] -> true + | _ -> false + in + let is_onconcl = match cl.concl_occs with + | AllOccurrences | NoOccurrences -> true + | _ -> false + in + let c_interp patvars = { Sigma.run = begin fun sigma -> + let lfun' = Id.Map.fold (fun id c lfun -> + Id.Map.add id (Value.of_constr c) lfun) + patvars ist.lfun + in + let sigma = Sigma.to_evar_map sigma in + let ist = { ist with lfun = lfun' } in + let (sigma, c) = + if is_onhyps && is_onconcl + then interp_type ist (pf_env gl) sigma c + else interp_constr ist (pf_env gl) sigma c + in + Sigma.Unsafe.of_pair (c, sigma) + end } in + Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl) + end } + end + | TacChange (Some op,c,cl) -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"") begin + Proofview.V82.nf_evar_goals <*> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let op = interp_typed_pattern ist env sigma op in + let to_catch = function Not_found -> true | e -> CErrors.is_anomaly e in + let c_interp patvars = { Sigma.run = begin fun sigma -> + let lfun' = Id.Map.fold (fun id c lfun -> + Id.Map.add id (Value.of_constr c) lfun) + patvars ist.lfun + in + let ist = { ist with lfun = lfun' } in + try + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_constr ist env sigma c in + Sigma.Unsafe.of_pair (c, sigma) + with e when to_catch e (* Hack *) -> + user_err (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") + end } in + Tactics.change (Some op) c_interp (interp_clause ist env sigma cl) + end } + end + + + (* Equality and inversion *) + | TacRewrite (ev,l,cl,by) -> + Proofview.Goal.enter { enter = begin fun gl -> + let l' = List.map (fun (b,m,(keep,c)) -> + let f = { delayed = fun env sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_open_constr_with_bindings ist env sigma c in + Sigma.Unsafe.of_pair (c, sigma) + } in + (b,m,keep,f)) l in + let env = Proofview.Goal.env gl in + let sigma = project gl in + let cl = interp_clause ist env sigma cl in + name_atomic ~env + (TacRewrite (ev,l,cl,Option.map ignore by)) + (Equality.general_multi_rewrite ev l' cl + (Option.map (fun by -> Tacticals.New.tclCOMPLETE (interp_tactic ist by), + Equality.Naive) + by)) + end } + | TacInversion (DepInversion (k,c,ids),hyp) -> + Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let (sigma,c_interp) = + match c with + | None -> sigma , None + | Some c -> + let (sigma,c_interp) = interp_constr ist env sigma c in + sigma , Some c_interp + in + let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in + let sigma,ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env + (TacInversion(DepInversion(k,c_interp,ids),dqhyps)) + (Inv.dinv k c_interp ids_interp dqhyps)) sigma + end } + | TacInversion (NonDepInversion (k,idl,ids),hyp) -> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let hyps = interp_hyp_list ist env sigma idl in + let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in + let sigma, ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env + (TacInversion (NonDepInversion (k,hyps,ids),dqhyps)) + (Inv.inv_clause k ids_interp hyps dqhyps)) sigma + end } + | TacInversion (InversionUsing (c,idl),hyp) -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let (sigma,c_interp) = interp_constr ist env sigma c in + let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in + let hyps = interp_hyp_list ist env sigma idl in + let tac = name_atomic ~env + (TacInversion (InversionUsing (c_interp,hyps),dqhyps)) + (Leminv.lemInv_clause dqhyps c_interp hyps) + in + Sigma.Unsafe.of_pair (tac, sigma) + end } + +(* Initial call for interpretation *) + +let default_ist () = + let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in + { lfun = Id.Map.empty; extra = extra } + +let eval_tactic t = + Proofview.tclUNIT () >>= fun () -> (* delay for [default_ist] *) + Proofview.tclLIFT db_initialize <*> + interp_tactic (default_ist ()) t + +let eval_tactic_ist ist t = + Proofview.tclLIFT db_initialize <*> + interp_tactic ist t + +(* globalization + interpretation *) + + +let interp_tac_gen lfun avoid_ids debug t = + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let extra = TacStore.set TacStore.empty f_debug debug in + let extra = TacStore.set extra f_avoid_ids avoid_ids in + let ist = { lfun = lfun; extra = extra } in + let ltacvars = Id.Map.domain lfun in + interp_tactic ist + (intern_pure_tactic { + ltacvars; genv = env } t) + end } + +let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t + +(* Used to hide interpretation for pretty-print, now just launch tactics *) +(* [global] means that [t] should be internalized outside of goals. *) +let hide_interp global t ot = + let hide_interp env = + let ist = { ltacvars = Id.Set.empty; genv = env } in + let te = intern_pure_tactic ist t in + let t = eval_tactic te in + match ot with + | None -> t + | Some t' -> Tacticals.New.tclTHEN t t' + in + if global then + Proofview.tclENV >>= fun env -> + hide_interp env + else + Proofview.Goal.enter { enter = begin fun gl -> + hide_interp (Proofview.Goal.env gl) + end } + +(***************************************************************************) +(** Register standard arguments *) + +let register_interp0 wit f = + let open Ftactic.Notations in + let interp ist v = + f ist v >>= fun v -> Ftactic.return (Val.inject (val_tag wit) v) + in + Geninterp.register_interp0 wit interp + +let def_intern ist x = (ist, x) +let def_subst _ x = x +let def_interp ist x = Ftactic.return x + +let declare_uniform t = + Genintern.register_intern0 t def_intern; + Genintern.register_subst0 t def_subst; + register_interp0 t def_interp + +let () = + declare_uniform wit_unit + +let () = + declare_uniform wit_int + +let () = + declare_uniform wit_bool + +let () = + declare_uniform wit_string + +let () = + declare_uniform wit_pre_ident + +let lift f = (); fun ist x -> Ftactic.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + Ftactic.return (f ist env sigma x) +end } + +let lifts f = (); fun ist x -> Ftactic.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let (sigma, v) = f ist env sigma x in + Sigma.Unsafe.of_pair (Ftactic.return v, sigma) +end } + +let interp_bindings' ist bl = Ftactic.return { delayed = fun env sigma -> + let (sigma, bl) = interp_bindings ist env (Sigma.to_evar_map sigma) bl in + Sigma.Unsafe.of_pair (bl, sigma) + } + +let interp_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigma -> + let (sigma, c) = interp_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in + Sigma.Unsafe.of_pair (c, sigma) + } + +let interp_destruction_arg' ist c = Ftactic.nf_enter { enter = begin fun gl -> + Ftactic.return (interp_destruction_arg ist gl c) +end } + +let () = + register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); + register_interp0 wit_ref (lift interp_reference); + register_interp0 wit_ident (lift interp_ident); + register_interp0 wit_var (lift interp_hyp); + register_interp0 wit_intro_pattern (lifts interp_intro_pattern); + register_interp0 wit_clause_dft_concl (lift interp_clause); + register_interp0 wit_constr (lifts interp_constr); + register_interp0 wit_tacvalue (fun ist v -> Ftactic.return v); + register_interp0 wit_red_expr (lifts interp_red_expr); + register_interp0 wit_quant_hyp (lift interp_declared_or_quantified_hypothesis); + register_interp0 wit_open_constr (lifts interp_open_constr); + register_interp0 wit_bindings interp_bindings'; + register_interp0 wit_constr_with_bindings interp_constr_with_bindings'; + register_interp0 wit_destruction_arg interp_destruction_arg'; + () + +let () = + let interp ist tac = Ftactic.return (Value.of_closure ist tac) in + register_interp0 wit_tactic interp + +let () = + let interp ist tac = interp_tactic ist tac >>= fun () -> Ftactic.return () in + register_interp0 wit_ltac interp + +let () = + register_interp0 wit_uconstr (fun ist c -> Ftactic.nf_enter { enter = begin fun gl -> + Ftactic.return (interp_uconstr ist (Proofview.Goal.env gl) c) + end }) + +(***************************************************************************) +(* Other entry points *) + +let val_interp ist tac k = Ftactic.run (val_interp ist tac) k + +let interp_ltac_constr ist c k = Ftactic.run (interp_ltac_constr ist c) k + +let interp_redexp env sigma r = + let ist = default_ist () in + let gist = { fully_empty_glob_sign with genv = env; } in + interp_red_expr ist env sigma (intern_red_expr gist r) + +(***************************************************************************) +(* Backwarding recursive needs of tactic glob/interp/eval functions *) + +let _ = + let eval ty env sigma lfun arg = + let ist = { lfun = lfun; extra = TacStore.empty; } in + if Genarg.has_type arg (glbwit wit_tactic) then + let tac = Genarg.out_gen (glbwit wit_tactic) arg in + let tac = interp_tactic ist tac in + Pfedit.refine_by_tactic env sigma ty tac + else + failwith "not a tactic" + in + Hook.set Pretyping.genarg_interp_hook eval + +(** Used in tactic extension **) + +let dummy_id = Id.of_string "_" + +let lift_constr_tac_to_ml_tac vars tac = + let tac _ ist = Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let map = function + | None -> None + | Some id -> + let c = Id.Map.find id ist.lfun in + try Some (coerce_to_closed_constr env c) + with CannotCoerceTo ty -> + error_ltac_variable Loc.ghost dummy_id (Some (env,sigma)) c ty + in + let args = List.map_filter map vars in + tac args ist + end } in + tac + +let vernac_debug b = + set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) + +let _ = + let open Goptions in + declare_bool_option + { optsync = false; + optdepr = false; + optname = "Ltac debug"; + optkey = ["Ltac";"Debug"]; + optread = (fun () -> get_debug () != Tactic_debug.DebugOff); + optwrite = vernac_debug } + +let _ = + let open Goptions in + declare_bool_option + { optsync = false; + optdepr = false; + optname = "Ltac debug"; + optkey = ["Debug";"Ltac"]; + optread = (fun () -> get_debug () != Tactic_debug.DebugOff); + optwrite = vernac_debug } + +let () = Hook.set Vernacentries.interp_redexp_hook interp_redexp diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli new file mode 100644 index 000000000..6f64981ef --- /dev/null +++ b/plugins/ltac/tacinterp.mli @@ -0,0 +1,122 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t + val to_constr : t -> constr option + val of_int : int -> t + val to_int : t -> int option + val to_list : t -> t list option + val of_closure : Geninterp.interp_sign -> glob_tactic_expr -> t + val cast : 'a typed_abstract_argument_type -> Geninterp.Val.t -> 'a +end + +(** Values for interpretation *) +type value = Value.t + +module TacStore : Store.S with + type t = Geninterp.TacStore.t + and type 'a field = 'a Geninterp.TacStore.field + +(** Signature for interpretation: val\_interp and interpretation functions *) +type interp_sign = Geninterp.interp_sign = { + lfun : value Id.Map.t; + extra : TacStore.t } + +val f_avoid_ids : Id.t list TacStore.field +val f_debug : debug_info TacStore.field + +val extract_ltac_constr_values : interp_sign -> Environ.env -> + Pattern.constr_under_binders Id.Map.t +(** Given an interpretation signature, extract all values which are coercible to + a [constr]. *) + +(** Sets the debugger mode *) +val set_debug : debug_info -> unit + +(** Gives the state of debug *) +val get_debug : unit -> debug_info + +(** Adds an interpretation function for extra generic arguments *) + +val interp_genarg : interp_sign -> glob_generic_argument -> Value.t Ftactic.t + +(** Interprets any expression *) +val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tactic) -> unit Proofview.tactic + +(** Interprets an expression that evaluates to a constr *) +val interp_ltac_constr : interp_sign -> glob_tactic_expr -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic + +(** Interprets redexp arguments *) +val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr + +(** Interprets tactic expressions *) + +val interp_hyp : interp_sign -> Environ.env -> Evd.evar_map -> + Id.t Loc.located -> Id.t + +val interp_constr_gen : Pretyping.typing_constraint -> interp_sign -> + Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Evd.evar_map * constr + +val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> + glob_constr_and_expr bindings -> Evd.evar_map * constr bindings + +val interp_open_constr_with_bindings : interp_sign -> Environ.env -> Evd.evar_map -> + glob_constr_and_expr with_bindings -> Evd.evar_map * constr with_bindings + +(** Initial call for interpretation *) + +val eval_tactic : glob_tactic_expr -> unit Proofview.tactic + +val eval_tactic_ist : interp_sign -> glob_tactic_expr -> unit Proofview.tactic +(** Same as [eval_tactic], but with the provided [interp_sign]. *) + +val tactic_of_value : interp_sign -> Value.t -> unit Proofview.tactic + +(** Globalization + interpretation *) + +val interp_tac_gen : value Id.Map.t -> Id.t list -> + debug_info -> raw_tactic_expr -> unit Proofview.tactic + +val interp : raw_tactic_expr -> unit Proofview.tactic + +(** Hides interpretation for pretty-print *) + +val hide_interp : bool -> raw_tactic_expr -> unit Proofview.tactic option -> unit Proofview.tactic + +(** Internals that can be useful for syntax extensions. *) + +val interp_ltac_var : (value -> 'a) -> interp_sign -> + (Environ.env * Evd.evar_map) option -> Id.t Loc.located -> 'a + +val interp_int : interp_sign -> Id.t Loc.located -> int + +val interp_int_or_var : interp_sign -> int or_var -> int + +val error_ltac_variable : Loc.t -> Id.t -> + (Environ.env * Evd.evar_map) option -> value -> string -> 'a + +(** Transforms a constr-expecting tactic into a tactic finding its arguments in + the Ltac environment according to the given names. *) +val lift_constr_tac_to_ml_tac : Id.t option list -> + (constr list -> Geninterp.interp_sign -> unit Proofview.tactic) -> Tacenv.ml_tactic + +val default_ist : unit -> Geninterp.interp_sign +(** Empty ist with debug set on the current value. *) diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml new file mode 100644 index 000000000..55de58361 --- /dev/null +++ b/plugins/ltac/tacsubst.ml @@ -0,0 +1,308 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* NoBindings + | ImplicitBindings l -> ImplicitBindings (List.map (subst_glob_constr subst) l) + | ExplicitBindings l -> ExplicitBindings (List.map (subst_binding subst) l) + +let subst_glob_with_bindings subst (c,bl) = + (subst_glob_constr subst c, subst_bindings subst bl) + +let subst_glob_with_bindings_arg subst (clear,c) = + (clear,subst_glob_with_bindings subst c) + +let rec subst_intro_pattern subst = function + | loc,IntroAction p -> loc, IntroAction (subst_intro_pattern_action subst p) + | loc, IntroNaming _ | loc, IntroForthcoming _ as x -> x + +and subst_intro_pattern_action subst = function + | IntroApplyOn (t,pat) -> + IntroApplyOn (subst_glob_constr subst t,subst_intro_pattern subst pat) + | IntroOrAndPattern l -> + IntroOrAndPattern (subst_intro_or_and_pattern subst l) + | IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l) + | IntroWildcard | IntroRewrite _ as x -> x + +and subst_intro_or_and_pattern subst = function + | IntroAndPattern l -> + IntroAndPattern (List.map (subst_intro_pattern subst) l) + | IntroOrPattern ll -> + IntroOrPattern (List.map (List.map (subst_intro_pattern subst)) ll) + +let subst_destruction_arg subst = function + | clear,ElimOnConstr c -> clear,ElimOnConstr (subst_glob_with_bindings subst c) + | clear,ElimOnAnonHyp n as x -> x + | clear,ElimOnIdent id as x -> x + +let subst_and_short_name f (c,n) = +(* assert (n=None); *)(* since tacdef are strictly globalized *) + (f c,None) + +let subst_or_var f = function + | ArgVar _ as x -> x + | ArgArg x -> ArgArg (f x) + +let dloc = Loc.ghost + +let subst_located f (_loc,id) = (dloc,f id) + +let subst_reference subst = + subst_or_var (subst_located (subst_kn subst)) + +(*CSC: subst_global_reference is used "only" for RefArgType, that propagates + to the syntactic non-terminals "global", used in commands such as + Print. It is also used for non-evaluable references. *) +open Pp +open Printer + +let subst_global_reference subst = + let subst_global ref = + let ref',t' = subst_global subst ref in + if not (eq_constr (Universes.constr_of_global ref') t') then + Feedback.msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ + str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++ + pr_global ref') ; + ref' + in + subst_or_var (subst_located subst_global) + +let subst_evaluable subst = + let subst_eval_ref = subst_evaluable_reference subst in + subst_or_var (subst_and_short_name subst_eval_ref) + +let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c) + +let subst_glob_constr_or_pattern subst (bvars,c,p) = + (bvars,subst_glob_constr subst c,subst_pattern subst p) + +let subst_redexp subst = + Miscops.map_red_expr_gen + (subst_glob_constr subst) + (subst_evaluable subst) + (subst_glob_constr_or_pattern subst) + +let subst_raw_may_eval subst = function + | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_glob_constr subst c) + | ConstrContext (locid,c) -> ConstrContext (locid,subst_glob_constr subst c) + | ConstrTypeOf c -> ConstrTypeOf (subst_glob_constr subst c) + | 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)) + | Term pc -> Term (subst_glob_constr_or_pattern subst pc) + +let rec subst_match_goal_hyps subst = function + | Hyp (locs,mp) :: tl -> + Hyp (locs,subst_match_pattern subst mp) + :: subst_match_goal_hyps subst tl + | Def (locs,mv,mp) :: tl -> + Def (locs,subst_match_pattern subst mv, subst_match_pattern subst mp) + :: subst_match_goal_hyps subst tl + | [] -> [] + +let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with + (* Basic tactics *) + | TacIntroPattern (ev,l) -> TacIntroPattern (ev,List.map (subst_intro_pattern subst) l) + | TacApply (a,ev,cb,cl) -> + TacApply (a,ev,List.map (subst_glob_with_bindings_arg subst) cb,cl) + | TacElim (ev,cb,cbo) -> + TacElim (ev,subst_glob_with_bindings_arg subst cb, + Option.map (subst_glob_with_bindings subst) cbo) + | TacCase (ev,cb) -> TacCase (ev,subst_glob_with_bindings_arg subst cb) + | TacMutualFix (id,n,l) -> + TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l) + | TacMutualCofix (id,l) -> + TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l) + | TacAssert (b,otac,na,c) -> + TacAssert (b,Option.map (Option.map (subst_tactic subst)) otac,na, + subst_glob_constr subst c) + | TacGeneralize cl -> + TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl) + | TacLetTac (id,c,clp,b,eqpat) -> + TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat) + + (* Derived basic tactics *) + | TacInductionDestruct (isrec,ev,(l,el)) -> + let l' = List.map (fun (c,ids,cls) -> + subst_destruction_arg subst c, ids, cls) l in + let el' = Option.map (subst_glob_with_bindings subst) el in + TacInductionDestruct (isrec,ev,(l',el')) + + (* Conversion *) + | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl) + | TacChange (op,c,cl) -> + TacChange (Option.map (subst_glob_constr_or_pattern subst) op, + subst_glob_constr subst c, cl) + + (* Equality and inversion *) + | TacRewrite (ev,l,cl,by) -> + TacRewrite (ev, + List.map (fun (b,m,c) -> + b,m,subst_glob_with_bindings_arg subst c) l, + cl,Option.map (subst_tactic subst) by) + | TacInversion (DepInversion (k,c,l),hyp) -> + TacInversion (DepInversion (k,Option.map (subst_glob_constr subst) c,l),hyp) + | TacInversion (NonDepInversion _,_) as x -> x + | TacInversion (InversionUsing (c,cl),hyp) -> + TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp) + +and subst_tactic subst (t:glob_tactic_expr) = match t with + | TacAtom (_loc,t) -> TacAtom (dloc, subst_atomic subst t) + | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun) + | TacLetIn (r,l,u) -> + let l = List.map (fun (n,b) -> (n,subst_tacarg subst b)) l in + TacLetIn (r,l,subst_tactic subst u) + | TacMatchGoal (lz,lr,lmr) -> + TacMatchGoal(lz,lr, subst_match_rule subst lmr) + | TacMatch (lz,c,lmr) -> + TacMatch (lz,subst_tactic subst c,subst_match_rule subst lmr) + | TacId _ | TacFail _ as x -> x + | TacProgress tac -> TacProgress (subst_tactic subst tac:glob_tactic_expr) + | TacShowHyps tac -> TacShowHyps (subst_tactic subst tac:glob_tactic_expr) + | TacAbstract (tac,s) -> TacAbstract (subst_tactic subst tac,s) + | TacThen (t1,t2) -> + TacThen (subst_tactic subst t1, subst_tactic subst t2) + | TacDispatch tl -> TacDispatch (List.map (subst_tactic subst) tl) + | TacExtendTac (tf,t,tl) -> + TacExtendTac (Array.map (subst_tactic subst) tf, + subst_tactic subst t, + Array.map (subst_tactic subst) tl) + | TacThens (t,tl) -> + TacThens (subst_tactic subst t, List.map (subst_tactic subst) tl) + | TacThens3parts (t1,tf,t2,tl) -> + TacThens3parts (subst_tactic subst t1,Array.map (subst_tactic subst) tf, + subst_tactic subst t2,Array.map (subst_tactic subst) tl) + | TacDo (n,tac) -> TacDo (n,subst_tactic subst tac) + | TacTimeout (n,tac) -> TacTimeout (n,subst_tactic subst tac) + | TacTime (s,tac) -> TacTime (s,subst_tactic subst tac) + | TacTry tac -> TacTry (subst_tactic subst tac) + | TacInfo tac -> TacInfo (subst_tactic subst tac) + | TacRepeat tac -> TacRepeat (subst_tactic subst tac) + | TacOr (tac1,tac2) -> + TacOr (subst_tactic subst tac1,subst_tactic subst tac2) + | TacOnce tac -> + TacOnce (subst_tactic subst tac) + | TacExactlyOnce tac -> + TacExactlyOnce (subst_tactic subst tac) + | TacIfThenCatch (tac,tact,tace) -> + TacIfThenCatch ( + subst_tactic subst tac, + subst_tactic subst tact, + subst_tactic subst tace) + | TacOrelse (tac1,tac2) -> + TacOrelse (subst_tactic subst tac1,subst_tactic subst tac2) + | TacFirst l -> TacFirst (List.map (subst_tactic subst) l) + | TacSolve l -> TacSolve (List.map (subst_tactic subst) l) + | TacComplete tac -> TacComplete (subst_tactic subst tac) + | TacArg (_,a) -> TacArg (dloc,subst_tacarg subst a) + | TacSelect (s, tac) -> TacSelect (s, subst_tactic subst tac) + + (* For extensions *) + | TacAlias (_,s,l) -> + let s = subst_kn subst s in + TacAlias (dloc,s,List.map (subst_tacarg subst) l) + | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_tacarg subst) l) + +and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) + +and subst_tacarg subst = function + | Reference r -> Reference (subst_reference subst r) + | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c) + | TacCall (_loc,f,l) -> + TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l) + | TacFreshId _ as x -> x + | TacPretype c -> TacPretype (subst_glob_constr subst c) + | TacNumgoals -> TacNumgoals + | Tacexp t -> Tacexp (subst_tactic subst t) + | TacGeneric arg -> TacGeneric (subst_genarg subst arg) + +(* Reads the rules of a Match Context or a Match *) +and subst_match_rule subst = function + | (All tc)::tl -> + (All (subst_tactic subst tc))::(subst_match_rule subst tl) + | (Pat (rl,mp,tc))::tl -> + let hyps = subst_match_goal_hyps subst rl in + let pat = subst_match_pattern subst mp in + Pat (hyps,pat,subst_tactic subst tc) + ::(subst_match_rule subst tl) + | [] -> [] + +and subst_genarg subst (GenArg (Glbwit wit, x)) = + match wit with + | ListArg wit -> + let map x = + let ans = subst_genarg subst (in_gen (glbwit wit) x) in + out_gen (glbwit wit) ans + in + in_gen (glbwit (wit_list wit)) (List.map map x) + | OptArg wit -> + let ans = match x with + | None -> in_gen (glbwit (wit_opt wit)) None + | Some x -> + let s = out_gen (glbwit wit) (subst_genarg subst (in_gen (glbwit wit) x)) in + in_gen (glbwit (wit_opt wit)) (Some s) + in + ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = out_gen (glbwit wit1) (subst_genarg subst (in_gen (glbwit wit1) p)) in + let q = out_gen (glbwit wit2) (subst_genarg subst (in_gen (glbwit wit2) q)) in + in_gen (glbwit (wit_pair wit1 wit2)) (p, q) + | ExtraArg s -> + Genintern.generic_substitute subst (in_gen (glbwit wit) x) + +(** Registering *) + +let () = + Genintern.register_subst0 wit_int_or_var (fun _ v -> v); + Genintern.register_subst0 wit_ref subst_global_reference; + Genintern.register_subst0 wit_ident (fun _ v -> v); + Genintern.register_subst0 wit_var (fun _ v -> v); + Genintern.register_subst0 wit_intro_pattern (fun _ v -> v); + Genintern.register_subst0 wit_tactic subst_tactic; + Genintern.register_subst0 wit_ltac subst_tactic; + Genintern.register_subst0 wit_constr subst_glob_constr; + Genintern.register_subst0 wit_clause_dft_concl (fun _ v -> v); + Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c); + Genintern.register_subst0 wit_open_constr (fun subst c -> subst_glob_constr subst c); + Genintern.register_subst0 wit_red_expr subst_redexp; + Genintern.register_subst0 wit_quant_hyp subst_declared_or_quantified_hypothesis; + Genintern.register_subst0 wit_bindings subst_bindings; + Genintern.register_subst0 wit_constr_with_bindings subst_glob_with_bindings; + Genintern.register_subst0 wit_destruction_arg subst_destruction_arg; + () diff --git a/plugins/ltac/tacsubst.mli b/plugins/ltac/tacsubst.mli new file mode 100644 index 000000000..c1bf27257 --- /dev/null +++ b/plugins/ltac/tacsubst.mli @@ -0,0 +1,30 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* glob_tactic_expr -> glob_tactic_expr + +(** For generic arguments, we declare and store substitutions + in a table *) + +val subst_genarg : substitution -> glob_generic_argument -> glob_generic_argument + +(** Misc *) + +val subst_glob_constr_and_expr : + substitution -> glob_constr_and_expr -> glob_constr_and_expr + +val subst_glob_with_bindings : substitution -> + glob_constr_and_expr with_bindings -> + glob_constr_and_expr with_bindings diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml new file mode 100644 index 000000000..5cbddc7f6 --- /dev/null +++ b/plugins/ltac/tactic_debug.ml @@ -0,0 +1,422 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Printer.pr_constr_pattern p) rl + +(* This module intends to be a beginning of debugger for tactic expressions. + Currently, it is quite simple and we can hope to have, in the future, a more + complete panel of commands dedicated to a proof assistant framework *) + +(* Debug information *) +type debug_info = + | DebugOn of int + | DebugOff + +(* An exception handler *) +let explain_logic_error e = + CErrors.print (fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null))) + +let explain_logic_error_no_anomaly e = + CErrors.print_no_report + (fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null))) + +let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) +let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) + +(* Prints the goal *) + +let db_pr_goal gl = + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in + let penv = print_named_context env in + let pc = print_constr_env env concl in + str" " ++ hv 0 (penv ++ fnl () ++ + str "============================" ++ fnl () ++ + str" " ++ pc) ++ fnl () + +let db_pr_goal = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let pg = db_pr_goal gl in + Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) + end } + + +(* Prints the commands *) +let help () = + msg_tac_debug (str "Commands: = Continue" ++ fnl() ++ + str " h/? = Help" ++ fnl() ++ + str " r = Run times" ++ fnl() ++ + str " r = Run up to next idtac " ++ fnl() ++ + str " s = Skip" ++ fnl() ++ + str " x = Exit") + +(* Prints the goal and the command to be executed *) +let goal_com tac = + Proofview.tclTHEN + db_pr_goal + (Proofview.tclLIFT (msg_tac_debug (str "Going to execute:" ++ fnl () ++ prtac tac))) + +(* [run (new_ref _)] gives us a ref shared among [NonLogical.t] + expressions. It avoids parametrizing everything over a + reference. *) +let skipped = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) +let skip = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) +let breakpoint = Proofview.NonLogical.run (Proofview.NonLogical.ref None) + +let rec drop_spaces inst i = + if String.length inst > i && inst.[i] == ' ' then drop_spaces inst (i+1) + else i + +let possibly_unquote s = + if String.length s >= 2 && s.[0] == '"' && s.[String.length s - 1] == '"' then + String.sub s 1 (String.length s - 2) + else + s + +(* (Re-)initialize debugger *) +let db_initialize = + let open Proofview.NonLogical in + (skip:=0) >> (skipped:=0) >> (breakpoint:=None) + +let int_of_string s = + try Proofview.NonLogical.return (int_of_string s) + with e -> Proofview.NonLogical.raise e + +let string_get s i = + try Proofview.NonLogical.return (String.get s i) + with e -> Proofview.NonLogical.raise e + +(* Gives the number of steps or next breakpoint of a run command *) +let run_com inst = + let open Proofview.NonLogical in + string_get inst 0 >>= fun first_char -> + if first_char ='r' then + let i = drop_spaces inst 1 in + if String.length inst > i then + let s = String.sub inst i (String.length inst - i) in + if inst.[0] >= '0' && inst.[0] <= '9' then + int_of_string s >>= fun num -> + (if num<0 then invalid_arg "run_com" else return ()) >> + (skip:=num) >> (skipped:=0) + else + breakpoint:=Some (possibly_unquote s) + else + invalid_arg "run_com" + else + invalid_arg "run_com" + +(* Prints the run counter *) +let run ini = + let open Proofview.NonLogical in + if not ini then + begin + Proofview.NonLogical.print_notice (str"\b\r\b\r") >> + !skipped >>= fun skipped -> + msg_tac_debug (str "Executed expressions: " ++ int skipped ++ fnl()) + end >> + !skipped >>= fun x -> + skipped := x+1 + else + return () + +(* Prints the prompt *) +let rec prompt level = + (* spiwack: avoid overriding by the open below *) + let runtrue = run true in + begin + let open Proofview.NonLogical in + Proofview.NonLogical.print_notice (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >> + let exit = (skip:=0) >> (skipped:=0) >> raise Sys.Break in + Proofview.NonLogical.catch Proofview.NonLogical.read_line + begin function (e, info) -> match e with + | End_of_file -> exit + | e -> raise ~info e + end + >>= fun inst -> + match inst with + | "" -> return (DebugOn (level+1)) + | "s" -> return (DebugOff) + | "x" -> Proofview.NonLogical.print_char '\b' >> exit + | "h"| "?" -> + begin + help () >> + prompt level + end + | _ -> + Proofview.NonLogical.catch (run_com inst >> runtrue >> return (DebugOn (level+1))) + begin function (e, info) -> match e with + | Failure _ | Invalid_argument _ -> prompt level + | e -> raise ~info e + end + end + +(* Prints the state and waits for an instruction *) +(* spiwack: the only reason why we need to take the continuation [f] + as an argument rather than returning the new level directly seems to + be that [f] is wrapped in with "explain_logic_error". I don't think + it serves any purpose in the current design, so we could just drop + that. *) +let debug_prompt lev tac f = + (* spiwack: avoid overriding by the open below *) + let runfalse = run false in + let open Proofview.NonLogical in + let (>=) = Proofview.tclBIND in + (* What to print and to do next *) + let newlevel = + Proofview.tclLIFT !skip >= fun initial_skip -> + if Int.equal initial_skip 0 then + Proofview.tclLIFT !breakpoint >= fun breakpoint -> + if Option.is_empty breakpoint then Proofview.tclTHEN (goal_com tac) (Proofview.tclLIFT (prompt lev)) + else Proofview.tclLIFT(runfalse >> return (DebugOn (lev+1))) + else Proofview.tclLIFT begin + (!skip >>= fun s -> skip:=s-1) >> + runfalse >> + !skip >>= fun new_skip -> + (if Int.equal new_skip 0 then skipped:=0 else return ()) >> + return (DebugOn (lev+1)) + end in + newlevel >= fun newlevel -> + (* What to execute *) + Proofview.tclOR + (f newlevel) + begin fun (reraise, info) -> + Proofview.tclTHEN + (Proofview.tclLIFT begin + (skip:=0) >> (skipped:=0) >> + if Logic.catchable_exception reraise then + msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ explain_logic_error reraise) + else return () + end) + (Proofview.tclZERO ~info reraise) + end + +let is_debug db = + let open Proofview.NonLogical in + !breakpoint >>= fun breakpoint -> + match db, breakpoint with + | DebugOff, _ -> return false + | _, Some _ -> return false + | _ -> + !skip >>= fun skip -> + return (Int.equal skip 0) + +(* Prints a constr *) +let db_constr debug env c = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "Evaluated term: " ++ print_constr_env env c) + else return () + +(* Prints the pattern rule *) +let db_pattern_rule debug num r = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + begin + msg_tac_debug (str "Pattern rule " ++ int num ++ str ":" ++ fnl () ++ + str "|" ++ spc () ++ prmatchrl r) + end + else return () + +(* Prints the hypothesis pattern identifier if it exists *) +let hyp_bound = function + | Anonymous -> str " (unbound)" + | Name id -> str " (bound to " ++ pr_id id ++ str ")" + +(* Prints a matched hypothesis *) +let db_matched_hyp debug env (id,_,c) ido = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "Hypothesis " ++ pr_id id ++ hyp_bound ido ++ + str " has been matched: " ++ print_constr_env env c) + else return () + +(* Prints the matched conclusion *) +let db_matched_concl debug env c = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "Conclusion has been matched: " ++ print_constr_env env c) + else return () + +(* Prints a success message when the goal has been matched *) +let db_mc_pattern_success debug = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "The goal has been successfully matched!" ++ fnl() ++ + str "Let us execute the right-hand side part..." ++ fnl()) + else return () + +(* Prints a failure message for an hypothesis pattern *) +let db_hyp_pattern_failure debug env sigma (na,hyp) = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "The pattern hypothesis" ++ hyp_bound na ++ + str " cannot match: " ++ + prmatchpatt env sigma hyp) + else return () + +(* Prints a matching failure message for a rule *) +let db_matching_failure debug = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "This rule has failed due to matching errors!" ++ fnl() ++ + str "Let us try the next one...") + else return () + +(* Prints an evaluation failure message for a rule *) +let db_eval_failure debug s = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + let s = str "message \"" ++ s ++ str "\"" in + msg_tac_debug + (str "This rule has failed due to \"Fail\" tactic (" ++ + s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...") + else return () + +(* Prints a logic failure message for a rule *) +let db_logic_failure debug err = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + begin + msg_tac_debug (explain_logic_error err) >> + msg_tac_debug (str "This rule has failed due to a logic error!" ++ fnl() ++ + str "Let us try the next one...") + end + else return () + +let is_breakpoint brkname s = match brkname, s with + | Some s, MsgString s'::_ -> String.equal s s' + | _ -> false + +let db_breakpoint debug s = + let open Proofview.NonLogical in + !breakpoint >>= fun opt_breakpoint -> + match debug with + | DebugOn lev when not (CList.is_empty s) && is_breakpoint opt_breakpoint s -> + breakpoint:=None + | _ -> + return () + +(** Extrating traces *) + +let is_defined_ltac trace = + let rec aux = function + | (_, Tacexpr.LtacNameCall f) :: _ -> not (Tacenv.is_ltac_for_ml_tactic f) + | (_, Tacexpr.LtacNotationCall f) :: _ -> true + | (_, Tacexpr.LtacAtomCall _) :: _ -> false + | _ :: tail -> aux tail + | [] -> false in + aux (List.rev trace) + +let explain_ltac_call_trace last trace loc = + let calls = last :: List.rev_map snd trace in + let pr_call ck = match ck with + | Tacexpr.LtacNotationCall kn -> quote (Pptactic.pr_alias_key kn) + | Tacexpr.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) + | Tacexpr.LtacMLCall t -> + quote (Pptactic.pr_glob_tactic (Global.env()) t) + | Tacexpr.LtacVarCall (id,t) -> + quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ + Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" + | Tacexpr.LtacAtomCall te -> + quote (Pptactic.pr_glob_tactic (Global.env()) + (Tacexpr.TacAtom (Loc.ghost,te))) + | Tacexpr.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) -> + quote (Printer.pr_glob_constr_env (Global.env()) c) ++ + (if not (Id.Map.is_empty vars) then + strbrk " (with " ++ + prlist_with_sep pr_comma + (fun (id,c) -> + pr_id id ++ str ":=" ++ Printer.pr_lconstr_under_binders c) + (List.rev (Id.Map.bindings vars)) ++ str ")" + else mt()) + in + match calls with + | [] -> mt () + | [a] -> hov 0 (str "Ltac call to " ++ pr_call a ++ str " failed.") + | _ -> + let kind_of_last_call = match List.last calls with + | Tacexpr.LtacConstrInterp _ -> ", last term evaluation failed." + | _ -> ", last call failed." + in + hov 0 (str "In nested Ltac calls to " ++ + pr_enum pr_call calls ++ strbrk kind_of_last_call) + +let skip_extensions trace = + let rec aux = function + | (_,Tacexpr.LtacNameCall f as tac) :: _ + when Tacenv.is_ltac_for_ml_tactic f -> [tac] + | (_,Tacexpr.LtacNotationCall _ as tac) :: (_,Tacexpr.LtacMLCall _) :: _ -> + (* Case of an ML defined tactic with entry of the form <<"foo" args>> *) + (* see tacextend.mlp *) + [tac] + | (_,Tacexpr.LtacMLCall _ as tac) :: _ -> [tac] + | t :: tail -> t :: aux tail + | [] -> [] in + List.rev (aux (List.rev trace)) + +let finer_loc loc1 loc2 = Loc.merge loc1 loc2 = loc2 + +let extract_ltac_trace trace eloc = + let trace = skip_extensions trace in + let (loc,c),tail = List.sep_last trace in + if is_defined_ltac trace then + (* We entered a user-defined tactic, + we display the trace with location of the call *) + let msg = hov 0 (explain_ltac_call_trace c tail eloc ++ fnl()) in + Some msg, if finer_loc eloc loc then eloc else loc + else + (* We entered a primitive tactic, we don't display trace but + report on the finest location *) + let best_loc = + (* trace is with innermost call coming first *) + let rec aux best_loc = function + | (loc,_)::tail -> + if Loc.is_ghost best_loc || + not (Loc.is_ghost loc) && finer_loc loc best_loc + then + aux loc tail + else + aux best_loc tail + | [] -> best_loc in + aux eloc trace in + None, best_loc + +let get_ltac_trace (_, info) = + let ltac_trace = Exninfo.get info ltac_trace_info in + let loc = Option.default Loc.ghost (Loc.get_loc info) in + match ltac_trace with + | None -> None + | Some trace -> Some (extract_ltac_trace trace loc) + +let () = ExplainErr.register_additional_error_info get_ltac_trace diff --git a/plugins/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli new file mode 100644 index 000000000..520fb41ef --- /dev/null +++ b/plugins/ltac/tactic_debug.mli @@ -0,0 +1,80 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* glob_tactic_expr -> (debug_info -> 'a Proofview.tactic) -> 'a Proofview.tactic + +(** Initializes debugger *) +val db_initialize : unit Proofview.NonLogical.t + +(** Prints a constr *) +val db_constr : debug_info -> env -> constr -> unit Proofview.NonLogical.t + +(** Prints the pattern rule *) +val db_pattern_rule : + debug_info -> int -> (Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t + +(** Prints a matched hypothesis *) +val db_matched_hyp : + debug_info -> env -> Id.t * constr option * constr -> Name.t -> unit Proofview.NonLogical.t + +(** Prints the matched conclusion *) +val db_matched_concl : debug_info -> env -> constr -> unit Proofview.NonLogical.t + +(** Prints a success message when the goal has been matched *) +val db_mc_pattern_success : debug_info -> unit Proofview.NonLogical.t + +(** Prints a failure message for an hypothesis pattern *) +val db_hyp_pattern_failure : + debug_info -> env -> evar_map -> Name.t * constr_pattern match_pattern -> unit Proofview.NonLogical.t + +(** Prints a matching failure message for a rule *) +val db_matching_failure : debug_info -> unit Proofview.NonLogical.t + +(** Prints an evaluation failure message for a rule *) +val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit Proofview.NonLogical.t + +(** An exception handler *) +val explain_logic_error: exn -> Pp.std_ppcmds + +(** For use in the Ltac debugger: some exception that are usually + consider anomalies are acceptable because they are caught later in + the process that is being debugged. One should not require + from users that they report these anomalies. *) +val explain_logic_error_no_anomaly : exn -> Pp.std_ppcmds + +(** Prints a logic failure message for a rule *) +val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t + +(** Prints a logic failure message for a rule *) +val db_breakpoint : debug_info -> + Id.t Loc.located message_token list -> unit Proofview.NonLogical.t + +val extract_ltac_trace : + Tacexpr.ltac_trace -> Loc.t -> Pp.std_ppcmds option * Loc.t diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml new file mode 100644 index 000000000..ef45ee47e --- /dev/null +++ b/plugins/ltac/tactic_matching.ml @@ -0,0 +1,377 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + Constr_matching.bound_ident_map * Pattern.extended_patvar_map = + fun (l, lc) -> (l, Id.Map.map (fun c -> [], c) lc) + + +(** Adds a binding to a {!Id.Map.t} if the identifier is [Some id] *) +let id_map_try_add id x m = + match id with + | Some id -> Id.Map.add id x m + | None -> m + +(** Adds a binding to a {!Id.Map.t} if the name is [Name id] *) +let id_map_try_add_name id x m = + match id with + | Name id -> Id.Map.add id x m + | Anonymous -> m + +(** Takes the union of two {!Id.Map.t}. If there is conflict, + the binding of the right-hand argument shadows that of the left-hand + argument. *) +let id_map_right_biased_union m1 m2 = + if Id.Map.is_empty m1 then m2 (** Don't reconstruct the whole map *) + else Id.Map.fold Id.Map.add m2 m1 + +(** Tests whether the substitution [s] is empty. *) +let is_empty_subst (ln,lm) = + Id.Map.(is_empty ln && is_empty lm) + +(** {6 Non-linear patterns} *) + + +(** The patterns of Ltac are not necessarily linear. Non-linear + pattern are partially handled by the {!Matching} module, however + goal patterns are not primitive to {!Matching}, hence we must deal + with non-linearity between hypotheses and conclusion. Subterms are + considered equal up to the equality implemented in + [equal_instances]. *) +(* spiwack: it doesn't seem to be quite the same rule for non-linear + term patterns and non-linearity between hypotheses and/or + conclusion. Indeed, in [Matching], matching is made modulo + syntactic equality, and here we merge modulo conversion. It may be + a good idea to have an entry point of [Matching] with a partial + substitution as argument instead of merging substitution here. That + would ensure consistency. *) +let equal_instances env sigma (ctx',c') (ctx,c) = + (* How to compare instances? Do we want the terms to be convertible? + unifiable? Do we want the universe levels to be relevant? + (historically, conv_x is used) *) + CList.equal Id.equal ctx ctx' && Reductionops.is_conv env sigma c' c + + +(** Merges two substitutions. Raises [Not_coherent_metas] when + encountering two instances of the same metavariable which are not + equal according to {!equal_instances}. *) +exception Not_coherent_metas +let verify_metas_coherence env sigma (ln1,lcm) (ln,lm) = + let merge id oc1 oc2 = match oc1, oc2 with + | None, None -> None + | None, Some c | Some c, None -> Some c + | Some c1, Some c2 -> + if equal_instances env sigma c1 c2 then Some c1 + else raise Not_coherent_metas + in + let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 in + (** ppedrot: Is that even correct? *) + let merged = ln +++ ln1 in + (merged, Id.Map.merge merge lcm lm) + +let matching_error = + CErrors.UserError (Some "tactic matching" , Pp.str "No matching clauses for match.") + +let imatching_error = (matching_error, Exninfo.null) + +(** A functor is introduced to share the environment and the + evar_map. They do not change and it would be a pity to introduce + closures everywhere just for the occasional calls to + {!equal_instances}. *) +module type StaticEnvironment = sig + val env : Environ.env + val sigma : Evd.evar_map +end +module PatternMatching (E:StaticEnvironment) = struct + + + (** {6 The pattern-matching monad } *) + + + (** To focus on the algorithmic portion of pattern-matching, the + bookkeeping is relegated to a monad: the composition of the + bactracking monad of {!IStream.t} with a "writer" effect. *) + (* spiwack: as we don't benefit from the various stream optimisations + of Haskell, it may be costly to give the monad in direct style such as + here. We may want to use some continuation passing style. *) + type 'a tac = 'a Proofview.tactic + type 'a m = { stream : 'r. ('a -> unit t -> 'r tac) -> unit t -> 'r tac } + + (** The empty substitution. *) + let empty_subst = Id.Map.empty , Id.Map.empty + + (** Composes two substitutions using {!verify_metas_coherence}. It + must be a monoid with neutral element {!empty_subst}. Raises + [Not_coherent_metas] when composition cannot be achieved. *) + let subst_prod s1 s2 = + if is_empty_subst s1 then s2 + else if is_empty_subst s2 then s1 + else verify_metas_coherence E.env E.sigma s1 s2 + + (** The empty context substitution. *) + let empty_context_subst = Id.Map.empty + + (** Compose two context substitutions, in case of conflict the + right hand substitution shadows the left hand one. *) + let context_subst_prod = id_map_right_biased_union + + (** The empty term substitution. *) + let empty_term_subst = Id.Map.empty + + (** Compose two terms substitutions, in case of conflict the + right hand substitution shadows the left hand one. *) + let term_subst_prod = id_map_right_biased_union + + (** Merge two writers (and ignore the first value component). *) + let merge m1 m2 = + try Some { + subst = subst_prod m1.subst m2.subst; + context = context_subst_prod m1.context m2.context; + terms = term_subst_prod m1.terms m2.terms; + lhs = m2.lhs; + } + with Not_coherent_metas -> None + + (** Monadic [return]: returns a single success with empty substitutions. *) + let return (type a) (lhs:a) : a m = + { stream = fun k ctx -> k lhs ctx } + + (** Monadic bind: each success of [x] is replaced by the successes + of [f x]. The substitutions of [x] and [f x] are composed, + dropping the apparent successes when the substitutions are not + coherent. *) + let (>>=) (type a) (type b) (m:a m) (f:a -> b m) : b m = + { stream = fun k ctx -> m.stream (fun x ctx -> (f x).stream k ctx) ctx } + + (** A variant of [(>>=)] when the first argument returns [unit]. *) + let (<*>) (type a) (m:unit m) (y:a m) : a m = + { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx } + + (** Failure of the pattern-matching monad: no success. *) + let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error } + + let run (m : 'a m) = + let ctx = { + subst = empty_subst ; + context = empty_context_subst ; + terms = empty_term_subst ; + lhs = (); + } in + let eval lhs ctx = Proofview.tclUNIT { ctx with lhs } in + m.stream eval ctx + + (** Chooses in a list, in the same order as the list *) + let rec pick (l:'a list) (e, info) : 'a m = match l with + | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } + | x :: l -> + { stream = fun k ctx -> Proofview.tclOR (k x ctx) (fun e -> (pick l e).stream k ctx) } + + let pick l = pick l imatching_error + + (** Declares a subsitution, a context substitution and a term substitution. *) + let put subst context terms : unit m = + let s = { subst ; context ; terms ; lhs = () } in + { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s } + + (** Declares a substitution. *) + let put_subst subst : unit m = put subst empty_context_subst empty_term_subst + + (** Declares a term substitution. *) + let put_terms terms : unit m = put empty_subst empty_context_subst terms + + + + (** {6 Pattern-matching} *) + + + (** [wildcard_match_term lhs] matches a term against a wildcard + pattern ([_ => lhs]). It has a single success with an empty + substitution. *) + let wildcard_match_term = return + + (** [pattern_match_term refresh pat term lhs] returns the possible + matchings of [term] with the pattern [pat => lhs]. If refresh is + true, refreshes the universes of [term]. *) + let pattern_match_term refresh pat term lhs = +(* let term = if refresh then Termops.refresh_universes_strict term else term in *) + match pat with + | Term p -> + begin + try + put_subst (Constr_matching.extended_matches E.env E.sigma p term) <*> + return lhs + with Constr_matching.PatternMatchingFailure -> fail + end + | Subterm (with_app_context,id_ctxt,p) -> + + let rec map s (e, info) = + { stream = fun k ctx -> match IStream.peek s with + | IStream.Nil -> Proofview.tclZERO ~info e + | IStream.Cons ({ Constr_matching.m_sub ; m_ctx }, s) -> + let subst = adjust m_sub in + let context = id_map_try_add id_ctxt m_ctx Id.Map.empty in + let terms = empty_term_subst in + let nctx = { subst ; context ; terms ; lhs = () } in + match merge ctx nctx with + | None -> (map s (e, info)).stream k ctx + | 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 + + + (** [rule_match_term term rule] matches the term [term] with the + matching rule [rule]. *) + let rule_match_term term = function + | All lhs -> wildcard_match_term lhs + | Pat ([],pat,lhs) -> pattern_match_term false pat term lhs + | Pat _ -> + (** Rules with hypotheses, only work in match goal. *) + fail + + (** [match_term term rules] matches the term [term] with the set of + matching rules [rules].*) + let rec match_term (e, info) term rules = match rules with + | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } + | r :: rules -> + { stream = fun k ctx -> + let head = rule_match_term term r in + let tail e = match_term e term rules in + Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx) + } + + + (** [hyp_match_type hypname pat hyps] matches a single + hypothesis pattern [hypname:pat] against the hypotheses in + [hyps]. Tries the hypotheses in order. For each success returns + the name of the matched hypothesis. *) + let hyp_match_type hypname pat hyps = + pick hyps >>= fun decl -> + let id = NamedDecl.get_id decl in + let refresh = is_local_def decl in + pattern_match_term refresh pat (NamedDecl.get_type decl) () <*> + put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*> + return id + + (** [hyp_match_type hypname bodypat typepat hyps] matches a single + hypothesis pattern [hypname := bodypat : typepat] against the + hypotheses in [hyps].Tries the hypotheses in order. For each + success returns the name of the matched hypothesis. *) + let hyp_match_body_and_type hypname bodypat typepat hyps = + pick hyps >>= function + | LocalDef (id,body,hyp) -> + pattern_match_term false bodypat body () <*> + pattern_match_term true typepat hyp () <*> + put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*> + return id + | LocalAssum (id,hyp) -> fail + + (** [hyp_match pat hyps] dispatches to + {!hyp_match_type} or {!hyp_match_body_and_type} depending on whether + [pat] is [Hyp _] or [Def _]. *) + let hyp_match pat hyps = + match pat with + | Hyp ((_,hypname),typepat) -> + hyp_match_type hypname typepat hyps + | Def ((_,hypname),bodypat,typepat) -> + hyp_match_body_and_type hypname bodypat typepat hyps + + (** [hyp_pattern_list_match pats hyps lhs], matches the list of + patterns [pats] against the hypotheses in [hyps], and eventually + returns [lhs]. *) + let rec hyp_pattern_list_match pats hyps lhs = + match pats with + | pat::pats -> + hyp_match pat hyps >>= fun matched_hyp -> + (* spiwack: alternatively it is possible to return the list + with the matched hypothesis removed directly in + [hyp_match]. *) + let select_matched_hyp decl = Id.equal (NamedDecl.get_id decl) matched_hyp in + let hyps = CList.remove_first select_matched_hyp hyps in + hyp_pattern_list_match pats hyps lhs + | [] -> return lhs + + (** [rule_match_goal hyps concl rule] matches the rule [rule] + against the goal [hyps|-concl]. *) + let rule_match_goal hyps concl = function + | All lhs -> wildcard_match_term lhs + | Pat (hyppats,conclpat,lhs) -> + (* the rules are applied from the topmost one (in the concrete + syntax) to the bottommost. *) + let hyppats = List.rev hyppats in + pattern_match_term false conclpat concl () <*> + hyp_pattern_list_match hyppats hyps lhs + + (** [match_goal hyps concl rules] matches the goal [hyps|-concl] + with the set of matching rules [rules]. *) + let rec match_goal (e, info) hyps concl rules = match rules with + | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } + | r :: rules -> + { stream = fun k ctx -> + let head = rule_match_goal hyps concl r in + let tail e = match_goal e hyps concl rules in + Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx) + } + +end + +(** [match_term env sigma term rules] matches the term [term] with the + set of matching rules [rules]. The environment [env] and the + evar_map [sigma] are not currently used, but avoid code + duplication. *) +let match_term env sigma term rules = + let module E = struct + let env = env + let sigma = sigma + end in + let module M = PatternMatching(E) in + M.run (M.match_term imatching_error term rules) + + +(** [match_goal env sigma hyps concl rules] matches the goal + [hyps|-concl] with the set of matching rules [rules]. The + environment [env] and the evar_map [sigma] are used to check + convertibility for pattern variables shared between hypothesis + patterns or the conclusion pattern. *) +let match_goal env sigma hyps concl rules = + let module E = struct + let env = env + let sigma = sigma + end in + let module M = PatternMatching(E) in + M.run (M.match_goal imatching_error hyps concl rules) diff --git a/plugins/ltac/tactic_matching.mli b/plugins/ltac/tactic_matching.mli new file mode 100644 index 000000000..090207bcc --- /dev/null +++ b/plugins/ltac/tactic_matching.mli @@ -0,0 +1,49 @@ + (************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + Evd.evar_map -> + Term.constr -> + (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> + Tacexpr.glob_tactic_expr t Proofview.tactic + +(** [match_goal env sigma hyps concl rules] matches the goal + [hyps|-concl] with the set of matching rules [rules]. The + environment [env] and the evar_map [sigma] are used to check + convertibility for pattern variables shared between hypothesis + patterns or the conclusion pattern. *) +val match_goal: + Environ.env -> + Evd.evar_map -> + Context.Named.t -> + Term.constr -> + (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> + Tacexpr.glob_tactic_expr t Proofview.tactic diff --git a/plugins/ltac/tactic_option.ml b/plugins/ltac/tactic_option.ml new file mode 100644 index 000000000..a5ba3b837 --- /dev/null +++ b/plugins/ltac/tactic_option.ml @@ -0,0 +1,51 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* obj = + declare_object + { (default_object name) with + cache_function = cache; + load_function = (fun _ -> load); + open_function = (fun _ -> load); + classify_function = (fun (local, tac) -> + if local then Dispose else Substitute (local, tac)); + subst_function = subst} + in + let put local tac = + set_default_tactic local tac; + Lib.add_anonymous_leaf (input (local, tac)) + in + let get () = !locality, Tacinterp.eval_tactic !default_tactic in + let print () = + Pptactic.pr_glob_tactic (Global.env ()) !default_tactic_expr ++ + (if !locality then str" (locally defined)" else str" (globally defined)") + in + put, get, print diff --git a/plugins/ltac/tactic_option.mli b/plugins/ltac/tactic_option.mli new file mode 100644 index 000000000..ed759a76d --- /dev/null +++ b/plugins/ltac/tactic_option.mli @@ -0,0 +1,15 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* string -> + (* put *) (locality_flag -> glob_tactic_expr -> unit) * + (* get *) (unit -> locality_flag * unit Proofview.tactic) * + (* print *) (unit -> Pp.std_ppcmds) diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml new file mode 100644 index 000000000..756958c2f --- /dev/null +++ b/plugins/ltac/tauto.ml @@ -0,0 +1,279 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* c + | None -> failwith "tauto: anomaly" + +(** Parametrization of tauto *) + +type tauto_flags = { + +(* Whether conjunction and disjunction are restricted to binary connectives *) + binary_mode : bool; + +(* Whether compatibility for buggy detection of binary connective is on *) + binary_mode_bugged_detection : bool; + +(* Whether conjunction and disjunction are restricted to the connectives *) +(* having the structure of "and" and "or" (up to the choice of sorts) in *) +(* contravariant position in an hypothesis *) + strict_in_contravariant_hyp : bool; + +(* Whether conjunction and disjunction are restricted to the connectives *) +(* having the structure of "and" and "or" (up to the choice of sorts) in *) +(* an hypothesis and in the conclusion *) + strict_in_hyp_and_ccl : bool; + +(* Whether unit type includes equality types *) + strict_unit : bool; +} + +let tag_tauto_flags : tauto_flags Val.typ = Val.create "tauto_flags" + +let assoc_flags ist : tauto_flags = + let Val.Dyn (tag, v) = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in + match Val.eq tag tag_tauto_flags with + | None -> assert false + | Some Refl -> v + +(* Whether inner not are unfolded *) +let negation_unfolding = ref true + +(* Whether inner iff are unfolded *) +let iff_unfolding = ref false + +let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2 + +open Goptions +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "unfolding of not in intuition"; + optkey = ["Intuition";"Negation";"Unfolding"]; + optread = (fun () -> !negation_unfolding); + optwrite = (:=) negation_unfolding } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "unfolding of iff in intuition"; + optkey = ["Intuition";"Iff";"Unfolding"]; + optread = (fun () -> !iff_unfolding); + optwrite = (:=) iff_unfolding } + +(** Base tactics *) + +let loc = Loc.ghost +let idtac = Proofview.tclUNIT () +let fail = Proofview.tclINDEPENDENT (tclFAIL 0 (Pp.mt ())) + +let intro = Tactics.intro + +let assert_ ?by c = + let tac = match by with + | None -> None + | Some tac -> Some (Some tac) + in + Proofview.tclINDEPENDENT (Tactics.forward true tac None c) + +let apply c = Tactics.apply c + +let clear id = Tactics.clear [id] + +let assumption = Tactics.assumption + +let split = Tactics.split_with_bindings false [Misctypes.NoBindings] + +(** Test *) + +let is_empty _ ist = + if is_empty_type (assoc_var "X1" ist) then idtac else fail + +(* Strictly speaking, this exceeds the propositional fragment as it + matches also equality types (and solves them if a reflexivity) *) +let is_unit_or_eq _ ist = + let flags = assoc_flags ist in + let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in + if test (assoc_var "X1" ist) then idtac else fail + +let bugged_is_binary t = + isApp t && + let (hdapp,args) = decompose_app t in + match (kind_of_term hdapp) with + | Ind (ind,u) -> + let (mib,mip) = Global.lookup_inductive ind in + Int.equal mib.Declarations.mind_nparams 2 + | _ -> false + +(** Dealing with conjunction *) + +let is_conj _ ist = + let flags = assoc_flags ist in + let ind = assoc_var "X1" ist in + if (not flags.binary_mode_bugged_detection || bugged_is_binary ind) && + is_conjunction + ~strict:flags.strict_in_hyp_and_ccl + ~onlybinary:flags.binary_mode ind + then idtac + else fail + +let flatten_contravariant_conj _ ist = + let flags = assoc_flags ist in + let typ = assoc_var "X1" ist in + let c = assoc_var "X2" ist in + let hyp = assoc_var "id" ist in + match match_with_conjunction + ~strict:flags.strict_in_contravariant_hyp + ~onlybinary:flags.binary_mode typ + with + | Some (_,args) -> + let newtyp = List.fold_right mkArrow args c in + let intros = tclMAP (fun _ -> intro) args in + let by = tclTHENLIST [intros; apply hyp; split; assumption] in + tclTHENLIST [assert_ ~by newtyp; clear (destVar hyp)] + | _ -> fail + +(** Dealing with disjunction *) + +let is_disj _ ist = + let flags = assoc_flags ist in + let t = assoc_var "X1" ist in + if (not flags.binary_mode_bugged_detection || bugged_is_binary t) && + is_disjunction + ~strict:flags.strict_in_hyp_and_ccl + ~onlybinary:flags.binary_mode t + then idtac + else fail + +let flatten_contravariant_disj _ ist = + let flags = assoc_flags ist in + let typ = assoc_var "X1" ist in + let c = assoc_var "X2" ist in + let hyp = assoc_var "id" ist in + match match_with_disjunction + ~strict:flags.strict_in_contravariant_hyp + ~onlybinary:flags.binary_mode + typ with + | Some (_,args) -> + let map i arg = + let typ = mkArrow arg c in + let ci = Tactics.constructor_tac false None (succ i) Misctypes.NoBindings in + let by = tclTHENLIST [intro; apply hyp; ci; assumption] in + assert_ ~by typ + in + let tacs = List.mapi map args in + let tac0 = clear (destVar hyp) in + tclTHEN (tclTHENLIST tacs) tac0 + | _ -> fail + +let make_unfold name = + let dir = DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]) in + let const = Constant.make2 (MPfile dir) (Label.make name) in + (Locus.AllOccurrences, ArgArg (EvalConstRef const, None)) + +let u_iff = make_unfold "iff" +let u_not = make_unfold "not" + +let reduction_not_iff _ ist = + let make_reduce c = TacAtom (loc, TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in + let tac = match !negation_unfolding, unfold_iff () with + | true, true -> make_reduce [u_not; u_iff] + | true, false -> make_reduce [u_not] + | false, true -> make_reduce [u_iff] + | false, false -> TacId [] + in + eval_tactic_ist ist tac + +let coq_nnpp_path = + let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in + Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP") + +let apply_nnpp _ ist = + Proofview.tclBIND + (Proofview.tclUNIT ()) + begin fun () -> try + let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in + apply nnpp + with Not_found -> tclFAIL 0 (Pp.mt ()) + end + +(* This is the uniform mode dealing with ->, not, iff and types isomorphic to + /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types. + For the moment not and iff are still always unfolded. *) +let tauto_uniform_unit_flags = { + binary_mode = true; + binary_mode_bugged_detection = false; + strict_in_contravariant_hyp = true; + strict_in_hyp_and_ccl = true; + strict_unit = false +} + +(* This is the compatibility mode (not used) *) +let tauto_legacy_flags = { + binary_mode = true; + binary_mode_bugged_detection = true; + strict_in_contravariant_hyp = true; + strict_in_hyp_and_ccl = false; + strict_unit = false +} + +(* This is the improved mode *) +let tauto_power_flags = { + binary_mode = false; (* support n-ary connectives *) + binary_mode_bugged_detection = false; + strict_in_contravariant_hyp = false; (* supports non-regular connectives *) + strict_in_hyp_and_ccl = false; + strict_unit = false +} + +let with_flags flags _ ist = + let f = (loc, Id.of_string "f") in + let x = (loc, Id.of_string "x") in + let arg = Val.Dyn (tag_tauto_flags, flags) in + let ist = { ist with lfun = Id.Map.add (snd x) arg ist.lfun } in + eval_tactic_ist ist (TacArg (loc, TacCall (loc, ArgVar f, [Reference (ArgVar x)]))) + +let register_tauto_tactic tac name0 args = + let ids = List.map (fun id -> Id.of_string id) args in + let ids = List.map (fun id -> Some id) ids in + let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in + let entry = { mltac_name = name; mltac_index = 0 } in + let () = Tacenv.register_ml_tactic name [| tac |] in + let tac = TacFun (ids, TacML (loc, entry, [])) in + let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in + Mltop.declare_cache_obj obj tauto_plugin + +let () = register_tauto_tactic is_empty "is_empty" ["tauto_flags"; "X1"] +let () = register_tauto_tactic is_unit_or_eq "is_unit_or_eq" ["tauto_flags"; "X1"] +let () = register_tauto_tactic is_disj "is_disj" ["tauto_flags"; "X1"] +let () = register_tauto_tactic is_conj "is_conj" ["tauto_flags"; "X1"] +let () = register_tauto_tactic flatten_contravariant_disj "flatten_contravariant_disj" ["tauto_flags"; "X1"; "X2"; "id"] +let () = register_tauto_tactic flatten_contravariant_conj "flatten_contravariant_conj" ["tauto_flags"; "X1"; "X2"; "id"] +let () = register_tauto_tactic apply_nnpp "apply_nnpp" [] +let () = register_tauto_tactic reduction_not_iff "reduction_not_iff" [] +let () = register_tauto_tactic (with_flags tauto_uniform_unit_flags) "with_uniform_flags" ["f"] +let () = register_tauto_tactic (with_flags tauto_power_flags) "with_power_flags" ["f"] diff --git a/plugins/ltac/tauto.mli b/plugins/ltac/tauto.mli new file mode 100644 index 000000000..e69de29bb diff --git a/plugins/ltac/vo.itarget b/plugins/ltac/vo.itarget new file mode 100644 index 000000000..a28fb770b --- /dev/null +++ b/plugins/ltac/vo.itarget @@ -0,0 +1 @@ +Ltac.vo diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index 48fbe0793..edcd53005 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -88,9 +88,12 @@ Open Scope type_scope. (** ML Tactic Notations *) +Declare ML Module "ltac_plugin". Declare ML Module "coretactics". Declare ML Module "extratactics". Declare ML Module "g_auto". Declare ML Module "g_class". Declare ML Module "g_eqdecide". Declare ML Module "g_rewrite". + +Global Set Default Proof Mode "Classic". diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index d9f8ed881..cc1c44fe3 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -603,8 +603,6 @@ let init_toplevel arglist = init_gc (); Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) Lib.init(); - (* Default Proofb Mode starts with an alternative default. *) - Goptions.set_string_option_value ["Default";"Proof";"Mode"] "Classic"; begin try let extras = parse_args arglist in -- cgit v1.2.3 From ebc0870ca932acf0ceea5fe513e2ca40e74c2a02 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 6 Oct 2016 17:34:12 +0200 Subject: Moving the Ltac plugin to a pack-based one. This is cumbersome, because now code may fail at link time if it's not referring to the correct module name. Therefore, one has to add corresponding open statements a the top of every file depending on a Ltac module. This includes seemingly unrelated files that use EXTEND statements. --- plugins/btauto/g_btauto.ml4 | 2 ++ plugins/cc/g_congruence.ml4 | 1 + plugins/decl_mode/decl_interp.ml | 1 + plugins/decl_mode/decl_proof_instr.ml | 1 + plugins/decl_mode/g_decl_mode.ml4 | 1 + plugins/decl_mode/ppdecl_proof.ml | 1 + plugins/extraction/g_extraction.ml4 | 1 + plugins/firstorder/g_ground.ml4 | 1 + plugins/firstorder/ground.ml | 1 + plugins/fourier/g_fourier.ml4 | 1 + plugins/funind/g_indfun.ml4 | 1 + plugins/funind/invfun.ml | 1 + plugins/ltac/ltac_plugin.mllib | 27 --------------------------- plugins/ltac/ltac_plugin.mlpack | 27 +++++++++++++++++++++++++++ plugins/micromega/g_micromega.ml4 | 1 + plugins/nsatz/g_nsatz.ml4 | 4 ++-- plugins/omega/g_omega.ml4 | 1 + plugins/quote/g_quote.ml4 | 1 + plugins/romega/g_romega.ml4 | 1 + plugins/rtauto/g_rtauto.ml4 | 2 ++ plugins/rtauto/refl_tauto.ml | 1 + plugins/setoid_ring/g_newring.ml4 | 1 + plugins/setoid_ring/newring.ml | 1 + plugins/ssrmatching/ssrmatching.ml4 | 1 + test-suite/bugs/closed/3612.v | 3 +++ test-suite/bugs/closed/3649.v | 2 ++ test-suite/bugs/closed/4121.v | 4 +++- test-suite/bugs/closed/4527.v | 1 + test-suite/bugs/closed/4533.v | 3 ++- test-suite/bugs/closed/4544.v | 3 ++- 30 files changed, 65 insertions(+), 32 deletions(-) delete mode 100644 plugins/ltac/ltac_plugin.mllib create mode 100644 plugins/ltac/ltac_plugin.mlpack (limited to 'plugins') diff --git a/plugins/btauto/g_btauto.ml4 b/plugins/btauto/g_btauto.ml4 index f3e2c99f4..298027448 100644 --- a/plugins/btauto/g_btauto.ml4 +++ b/plugins/btauto/g_btauto.ml4 @@ -8,6 +8,8 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin + DECLARE PLUGIN "btauto_plugin" TACTIC EXTEND btauto diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index 6f6811334..7e76854b1 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -8,6 +8,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Cctac open Stdarg diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index f68c01b18..2b63ed6d6 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open CErrors open Util open Names diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index e19dc86c4..deb2ede1d 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open CErrors open Util open Pp diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index 18a35c6cf..a71d20f0d 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -10,6 +10,7 @@ DECLARE PLUGIN "decl_mode_plugin" +open Ltac_plugin open Compat open Pp open Decl_expr diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml index 59a0bb5a2..f5de638ed 100644 --- a/plugins/decl_mode/ppdecl_proof.ml +++ b/plugins/decl_mode/ppdecl_proof.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open CErrors open Pp open Decl_expr diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index e1d6bb4a8..3ed959cf2 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -12,6 +12,7 @@ DECLARE PLUGIN "extraction_plugin" (* ML names *) +open Ltac_plugin open Genarg open Stdarg open Pcoq.Prim diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 260e86ad6..e28d6aa62 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -8,6 +8,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Formula open Sequent open Ground diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 628af4e71..d6cd7e2a0 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open Formula open Sequent open Rules diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4 index 7c665ae7b..1960fa835 100644 --- a/plugins/fourier/g_fourier.ml4 +++ b/plugins/fourier/g_fourier.ml4 @@ -8,6 +8,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open FourierR DECLARE PLUGIN "fourier_plugin" diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 6603a95a8..368b23be3 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Compat open Util open Term diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index c8b4e4833..70333b063 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open Tacexpr open Declarations open CErrors diff --git a/plugins/ltac/ltac_plugin.mllib b/plugins/ltac/ltac_plugin.mllib deleted file mode 100644 index af1c7149d..000000000 --- a/plugins/ltac/ltac_plugin.mllib +++ /dev/null @@ -1,27 +0,0 @@ -Tacarg -Pptactic -Pltac -Taccoerce -Tacsubst -Tacenv -Tactic_debug -Tacintern -Tacentries -Profile_ltac -Tactic_matching -Tacinterp -Evar_tactics -Tactic_option -Extraargs -G_obligations -Coretactics -Extratactics -Profile_ltac_tactics -G_auto -G_class -Rewrite -G_rewrite -Tauto -G_eqdecide -G_tactic -G_ltac diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack new file mode 100644 index 000000000..af1c7149d --- /dev/null +++ b/plugins/ltac/ltac_plugin.mlpack @@ -0,0 +1,27 @@ +Tacarg +Pptactic +Pltac +Taccoerce +Tacsubst +Tacenv +Tactic_debug +Tacintern +Tacentries +Profile_ltac +Tactic_matching +Tacinterp +Evar_tactics +Tactic_option +Extraargs +G_obligations +Coretactics +Extratactics +Profile_ltac_tactics +G_auto +G_class +Rewrite +G_rewrite +Tauto +G_eqdecide +G_tactic +G_ltac diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 index 79020ed03..ccb6daa11 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.ml4 @@ -16,6 +16,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Stdarg open Tacarg diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.ml4 index 5f906a8da..195dec362 100644 --- a/plugins/nsatz/g_nsatz.ml4 +++ b/plugins/nsatz/g_nsatz.ml4 @@ -1,5 +1,3 @@ -DECLARE PLUGIN "nsatz_plugin" - (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Type) (u v : sigT P) (s : transport (fun x => transport P x u.2 = v.2) r p..2 = q..2), p = q. +Declare ML Module "ltac_plugin". Declare ML Module "coretactics". +Set Default Proof Mode "Classic". + Goal forall (A : Type) (B : forall _ : A, Type) (x : @sigT A (fun x : A => B x)) (xx : @paths (@sigT A (fun x0 : A => B x0)) x x), @paths (@paths (@sigT A (fun x0 : A => B x0)) x x) xx diff --git a/test-suite/bugs/closed/3649.v b/test-suite/bugs/closed/3649.v index fc4c171e2..8687eaab0 100644 --- a/test-suite/bugs/closed/3649.v +++ b/test-suite/bugs/closed/3649.v @@ -2,7 +2,9 @@ (* File reduced by coq-bug-finder from original input, then from 9518 lines to 404 lines, then from 410 lines to 208 lines, then from 162 lines to 77 lines *) (* coqc version trunk (September 2014) compiled on Sep 18 2014 21:0:5 with OCaml 4.01.0 coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (07e4438bd758c2ced8caf09a6961ccd77d84e42b) *) +Declare ML Module "ltac_plugin". Declare ML Module "coretactics". +Set Default Proof Mode "Classic". Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). Reserved Notation "x = y" (at level 70, no associativity). Delimit Scope type_scope with type. diff --git a/test-suite/bugs/closed/4121.v b/test-suite/bugs/closed/4121.v index d34a2b8b1..816bc845f 100644 --- a/test-suite/bugs/closed/4121.v +++ b/test-suite/bugs/closed/4121.v @@ -4,6 +4,8 @@ Unset Strict Universe Declaration. (* coqc version 8.5beta1 (March 2015) compiled on Mar 11 2015 18:51:36 with OCaml 4.01.0 coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (8dbfee5c5f897af8186cb1bdfb04fd4f88eca677) *) +Declare ML Module "ltac_plugin". + Set Universe Polymorphism. Class Contr_internal (A : Type) := BuildContr { center : A }. Arguments center A {_}. @@ -13,4 +15,4 @@ Definition contr_paths_contr0 {A} `{Contr A} : Contr A := {| center := center A Instance contr_paths_contr1 {A} `{Contr A} : Contr A := {| center := center A |}. Check @contr_paths_contr0@{i}. Check @contr_paths_contr1@{i}. (* Error: Universe instance should have length 2 *) -(** It should have length 1, just like contr_paths_contr0 *) \ No newline at end of file +(** It should have length 1, just like contr_paths_contr0 *) diff --git a/test-suite/bugs/closed/4527.v b/test-suite/bugs/closed/4527.v index 08628377f..c6fcc24b6 100644 --- a/test-suite/bugs/closed/4527.v +++ b/test-suite/bugs/closed/4527.v @@ -5,6 +5,7 @@ then from 269 lines to 255 lines *) (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 coqtop version 8.5 (January 2016) *) +Declare ML Module "ltac_plugin". Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. diff --git a/test-suite/bugs/closed/4533.v b/test-suite/bugs/closed/4533.v index ae17fb145..64c7fd8eb 100644 --- a/test-suite/bugs/closed/4533.v +++ b/test-suite/bugs/closed/4533.v @@ -5,6 +5,7 @@ then from 285 lines to 271 lines *) (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 coqtop version 8.5 (January 2016) *) +Declare ML Module "ltac_plugin". Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. @@ -223,4 +224,4 @@ v = _) r, | [ |- p2 @ p0 @ p1 @ eissect (to O A) (g x) = r ] => idtac "good" | [ |- ?G ] => fail 1 "bad" G end. - Fail rewrite concat_p_pp. \ No newline at end of file + Fail rewrite concat_p_pp. diff --git a/test-suite/bugs/closed/4544.v b/test-suite/bugs/closed/4544.v index da140c931..64dd8c304 100644 --- a/test-suite/bugs/closed/4544.v +++ b/test-suite/bugs/closed/4544.v @@ -2,6 +2,7 @@ (* File reduced by coq-bug-finder from original input, then from 2553 lines to 1932 lines, then from 1946 lines to 1932 lines, then from 2467 lines to 1002 lines, then from 1016 lines to 1002 lines *) (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 coqtop version 8.5 (January 2016) *) +Declare ML Module "ltac_plugin". Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. @@ -1004,4 +1005,4 @@ Proof. Fail Timeout 1 Time rewrite !loops_functor_group. (* 0.004 s in 8.5rc1, 8.677 s in 8.5 *) Timeout 1 do 3 rewrite loops_functor_group. -Abort. \ No newline at end of file +Abort. -- cgit v1.2.3 From 04d086e21cdf28c4029133a0f8fd1720d13544e8 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 24 Feb 2017 12:27:47 +0100 Subject: Revert "Add empty ltac_plugin file for forward compatibility." This reverts commit e8137ae63b3b19436755f372b595e7343e942894, was meant for 8.6 branch only. --- ltac/ltac_plugin.ml | 0 ltac/ltac_plugin.mli | 0 plugins/ltac/ltac_plugin.mlpack | 1 - 3 files changed, 1 deletion(-) delete mode 100644 ltac/ltac_plugin.ml delete mode 100644 ltac/ltac_plugin.mli (limited to 'plugins') diff --git a/ltac/ltac_plugin.ml b/ltac/ltac_plugin.ml deleted file mode 100644 index e69de29bb..000000000 diff --git a/ltac/ltac_plugin.mli b/ltac/ltac_plugin.mli deleted file mode 100644 index e69de29bb..000000000 diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack index b6e2cecd1..af1c7149d 100644 --- a/plugins/ltac/ltac_plugin.mlpack +++ b/plugins/ltac/ltac_plugin.mlpack @@ -25,4 +25,3 @@ Tauto G_eqdecide G_tactic G_ltac -Ltac_plugin -- cgit v1.2.3 From a84797db94e9d242ebdf9f6feb08a63d42a14bae Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 24 Feb 2017 00:27:50 +0100 Subject: TACTIC EXTEND now takes an optional level as argument. The syntax is: TACTIC EXTEND foo AT LEVEL i This commit makes it possible to define tacticals like the ssreflect arrow without having to resort to GEXTEND statements and intepretation hacks. Note that it simply makes accessible through the ML interface what Tactic Notation already supports: Tactic Notation (at level 1) tactic1(t) "=>" ipats(l) := ... --- grammar/tacextend.mlp | 24 +++++++++++------------- plugins/ltac/tacentries.ml | 12 +++++++----- plugins/ltac/tacentries.mli | 2 +- 3 files changed, 19 insertions(+), 19 deletions(-) (limited to 'plugins') diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp index fe864ed40..6c1757dd2 100644 --- a/grammar/tacextend.mlp +++ b/grammar/tacextend.mlp @@ -82,14 +82,14 @@ let make_var = function | ExtNonTerminal (_, p) -> Some p | _ -> assert false -let declare_tactic loc s c cl = match cl with +let declare_tactic loc tacname ~level classification clause = match clause with | [(ExtTerminal name) :: rem, _, tac] when List.for_all is_constr_gram rem -> (** The extension is only made of a name followed by constr entries: we do not add any grammar nor printing rule and add it as a true Ltac definition. *) let patt = make_patt rem in let vars = List.map make_var rem in let vars = mlexpr_of_list (mlexpr_of_option mlexpr_of_ident) vars in - let entry = mlexpr_of_string s in + let entry = mlexpr_of_string tacname in let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in let ml = <:expr< { Tacexpr.mltac_name = $se$; Tacexpr.mltac_index = 0 } >> in let name = mlexpr_of_string name in @@ -117,13 +117,14 @@ let declare_tactic loc s c cl = match cl with | _ -> (** Otherwise we add parsing and printing rules to generate a call to a TacML tactic. *) - let entry = mlexpr_of_string s in + let entry = mlexpr_of_string tacname in let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in - let gl = mlexpr_of_clause cl in - let obj = <:expr< fun () -> Tacentries.add_ml_tactic_notation $se$ $gl$ >> in + let gl = mlexpr_of_clause clause in + let level = mlexpr_of_int level in + let obj = <:expr< fun () -> Tacentries.add_ml_tactic_notation $se$ $level$ $gl$ >> in declare_str_items loc [ <:str_item< do { - Tacenv.register_ml_tactic $se$ (Array.of_list $make_fun_clauses loc s cl$); + Tacenv.register_ml_tactic $se$ (Array.of_list $make_fun_clauses loc tacname clause$); Mltop.declare_cache_obj $obj$ $plugin_name$; } >> ] @@ -134,20 +135,17 @@ EXTEND GLOBAL: str_item; str_item: [ [ "TACTIC"; "EXTEND"; s = tac_name; + level = OPT [ "AT"; "LEVEL"; level = INT -> level ]; c = OPT [ "CLASSIFIED"; "BY"; c = LIDENT -> <:expr< $lid:c$ >> ]; OPT "|"; l = LIST1 tacrule SEP "|"; "END" -> - declare_tactic loc s c l ] ] + let level = match level with Some i -> int_of_string i | None -> 0 in + declare_tactic loc s ~level c l ] ] ; tacrule: [ [ "["; l = LIST1 tacargs; "]"; c = OPT [ "=>"; "["; c = Pcaml.expr; "]" -> c ]; - "->"; "["; e = Pcaml.expr; "]" -> - (match l with - | ExtNonTerminal _ :: _ -> - (* En attendant la syntaxe de tacticielles *) - failwith "Tactic syntax must start with an identifier" - | _ -> (l,c,e)) + "->"; "["; e = Pcaml.expr; "]" -> (l,c,e) ] ] ; tacargs: diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 2e2b55be7..8570b5a44 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -302,9 +302,9 @@ let cons_production_parameter = function | TacTerm _ -> None | TacNonTerm (_, _, id) -> Some id -let add_glob_tactic_notation local n prods forml ids tac = +let add_glob_tactic_notation local ~level prods forml ids tac = let parule = { - tacgram_level = n; + tacgram_level = level; tacgram_prods = prods; } in let tacobj = { @@ -360,7 +360,7 @@ let extend_atomic_tactic name entries = in List.iteri add_atomic entries -let add_ml_tactic_notation name prods = +let add_ml_tactic_notation name ~level prods = let len = List.length prods in let iter i prods = let open Tacexpr in @@ -372,10 +372,12 @@ let add_ml_tactic_notation name prods = let entry = { mltac_name = name; mltac_index = len - i - 1 } in let map id = Reference (Misctypes.ArgVar (Loc.ghost, id)) in let tac = TacML (Loc.ghost, entry, List.map map ids) in - add_glob_tactic_notation false 0 prods true ids tac + add_glob_tactic_notation false ~level prods true ids tac in List.iteri iter (List.rev prods); - extend_atomic_tactic name prods + (** We call [extend_atomic_tactic] only for "basic tactics" (the ones at + tactic_expr level 0) *) + if Int.equal level 0 then extend_atomic_tactic name prods (**********************************************************************) (** Ltac quotations *) diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index 969c118fb..069504473 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -45,7 +45,7 @@ val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type - to finding an argument by name (as in {!Genarg}) if there is none matching. *) -val add_ml_tactic_notation : ml_tactic_name -> +val add_ml_tactic_notation : ml_tactic_name -> level:int -> argument grammar_tactic_prod_item_expr list list -> unit (** A low-level variant of {!add_tactic_notation} used by the TACTIC EXTEND ML-side macro. *) -- cgit v1.2.3 From 5ee6e1ac4782ce0c2fb45f3927d210d3f1207053 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 2 Mar 2017 23:37:33 +0100 Subject: [ltac] Move dummy plugin to plugins folder. This is needed to fix `Declare ML Module "ltac_plugin". --- Makefile.common | 5 +++-- ltac/ltac.mllib | 1 - ltac/ltac_plugin.ml | 0 ltac/ltac_plugin.mli | 0 plugins/ltac/LtacDummy.v | 2 ++ plugins/ltac/ltac_dummy.ml | 0 plugins/ltac/ltac_dummy.mli | 0 plugins/ltac/ltac_plugin.mlpack | 1 + plugins/ltac/vo.itarget | 1 + 9 files changed, 7 insertions(+), 3 deletions(-) delete mode 100644 ltac/ltac_plugin.ml delete mode 100644 ltac/ltac_plugin.mli create mode 100644 plugins/ltac/LtacDummy.v create mode 100644 plugins/ltac/ltac_dummy.ml create mode 100644 plugins/ltac/ltac_dummy.mli create mode 100644 plugins/ltac/ltac_plugin.mlpack create mode 100644 plugins/ltac/vo.itarget (limited to 'plugins') diff --git a/Makefile.common b/Makefile.common index 49fe1fd93..a2b59a93b 100644 --- a/Makefile.common +++ b/Makefile.common @@ -62,7 +62,7 @@ PLUGINDIRS:=\ setoid_ring extraction fourier \ cc funind firstorder derive \ rtauto nsatz syntax decl_mode btauto \ - ssrmatching + ssrmatching ltac SRCDIRS:=\ $(CORESRCDIRS) \ @@ -120,6 +120,7 @@ OTHERSYNTAXCMO:=$(addprefix plugins/syntax/, \ string_syntax_plugin.cmo ) DECLMODECMO:=plugins/decl_mode/decl_mode_plugin.cmo DERIVECMO:=plugins/derive/derive_plugin.cmo +LTACCMO:=plugins/ltac/ltac_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo PLUGINSCMO:=$(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \ @@ -127,7 +128,7 @@ PLUGINSCMO:=$(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \ $(FOURIERCMO) $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ $(FUNINDCMO) $(NSATZCMO) $(NATSYNTAXCMO) $(OTHERSYNTAXCMO) \ - $(DERIVECMO) $(SSRMATCHINGCMO) + $(DERIVECMO) $(SSRMATCHINGCMO) $(LTACCMO) ifeq ($(HASNATDYNLINK)-$(BEST),false-opt) STATICPLUGINS:=$(PLUGINSCMO) diff --git a/ltac/ltac.mllib b/ltac/ltac.mllib index 974943ddd..fc51e48ae 100644 --- a/ltac/ltac.mllib +++ b/ltac/ltac.mllib @@ -20,4 +20,3 @@ G_rewrite Tauto G_eqdecide G_ltac -Ltac_plugin diff --git a/ltac/ltac_plugin.ml b/ltac/ltac_plugin.ml deleted file mode 100644 index e69de29bb..000000000 diff --git a/ltac/ltac_plugin.mli b/ltac/ltac_plugin.mli deleted file mode 100644 index e69de29bb..000000000 diff --git a/plugins/ltac/LtacDummy.v b/plugins/ltac/LtacDummy.v new file mode 100644 index 000000000..4f96bbaeb --- /dev/null +++ b/plugins/ltac/LtacDummy.v @@ -0,0 +1,2 @@ +(* The sole reason of this file is to trick coq's build system to build the dummy ltac plugin *) +Declare ML Module "ltac_plugin". diff --git a/plugins/ltac/ltac_dummy.ml b/plugins/ltac/ltac_dummy.ml new file mode 100644 index 000000000..e69de29bb diff --git a/plugins/ltac/ltac_dummy.mli b/plugins/ltac/ltac_dummy.mli new file mode 100644 index 000000000..e69de29bb diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack new file mode 100644 index 000000000..6efb477cc --- /dev/null +++ b/plugins/ltac/ltac_plugin.mlpack @@ -0,0 +1 @@ +Ltac_dummy diff --git a/plugins/ltac/vo.itarget b/plugins/ltac/vo.itarget new file mode 100644 index 000000000..4eff76566 --- /dev/null +++ b/plugins/ltac/vo.itarget @@ -0,0 +1 @@ +LtacDummy.vo -- cgit v1.2.3 From b5e6c189f378815c2cfc350924d225d7bd1287d4 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 9 Mar 2017 12:38:02 +0100 Subject: Micromega: removing a constant preventing micromega to be loaded before Logic.v. The constant was useless after 9f56baf which fixed #5073. --- plugins/micromega/coq_micromega.ml | 1 - 1 file changed, 1 deletion(-) (limited to 'plugins') diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index e4b58a56f..97f29df82 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -383,7 +383,6 @@ struct let coq_and = lazy (init_constant "and") let coq_or = lazy (init_constant "or") let coq_not = lazy (init_constant "not") - let coq_not_gl_ref = (Nametab.locate ( Libnames.qualid_of_string "Coq.Init.Logic.not")) let coq_iff = lazy (init_constant "iff") let coq_True = lazy (init_constant "True") -- cgit v1.2.3 From 028db341f3cb924c2d1b3a9e0fa5666425130f90 Mon Sep 17 00:00:00 2001 From: Tej Chajed Date: Thu, 9 Feb 2017 11:15:51 -0500 Subject: Report missing tactic arguments in error message Augments "A fully applied tactic is expected" with the list of missing arguments to the tactic. Addresses [bug 5344](https://coq.inria.fr/bugs/show_bug.cgi?id=5344). --- plugins/ltac/tacinterp.ml | 9 ++++++++- test-suite/output/ltac_missing_args.out | 21 +++++++++++++++++++++ test-suite/output/ltac_missing_args.v | 19 +++++++++++++++++++ 3 files changed, 48 insertions(+), 1 deletion(-) create mode 100644 test-suite/output/ltac_missing_args.out create mode 100644 test-suite/output/ltac_missing_args.v (limited to 'plugins') diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index aa646aa51..54bec3967 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -1422,7 +1422,14 @@ 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 _|VRec _) -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.") + | 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 pr_name vars ++ 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 tactic_of_value ist tac diff --git a/test-suite/output/ltac_missing_args.out b/test-suite/output/ltac_missing_args.out new file mode 100644 index 000000000..ae3fd7acc --- /dev/null +++ b/test-suite/output/ltac_missing_args.out @@ -0,0 +1,21 @@ +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable x. +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable x. +The command has indeed failed with message: +Error: A fully applied tactic is expected: +missing arguments for variables y and _. +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable x. +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable x. +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable _. +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable _. +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable _. +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable x. +The command has indeed failed with message: +Error: A fully applied tactic is expected: missing argument for variable x. diff --git a/test-suite/output/ltac_missing_args.v b/test-suite/output/ltac_missing_args.v new file mode 100644 index 000000000..8ecd97aa5 --- /dev/null +++ b/test-suite/output/ltac_missing_args.v @@ -0,0 +1,19 @@ +Ltac foo x := idtac x. +Ltac bar x := fun y _ => idtac x y. +Ltac baz := foo. +Ltac qux := bar. +Ltac mydo tac := tac (). +Ltac rec x := rec. + +Goal True. + Fail foo. + Fail bar. + Fail bar True. + Fail baz. + Fail qux. + Fail mydo ltac:(fun _ _ => idtac). + Fail let tac := (fun _ => idtac) in tac. + Fail (fun _ => idtac). + Fail rec True. + Fail let rec tac x := tac in tac True. +Abort. \ No newline at end of file -- cgit v1.2.3 From fa895511eaa1c374c72ea2096c1dfb33dfbee379 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 13:36:52 +0100 Subject: [safe-string] ltac/profile_ltac No functional change, one extra copy introduced but it seems hard to avoid. --- plugins/ltac/profile_ltac.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'plugins') diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index 2514ededb..58123f63e 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -257,7 +257,7 @@ let string_of_call ck = (Pptactic.pr_glob_tactic (Global.env ()) te) ) in - for i = 0 to String.length s - 1 do if s.[i] = '\n' then s.[i] <- ' ' done; + let s = String.map (fun c -> if c = '\n' then ' ' else c) s in let s = try String.sub s 0 (CString.string_index_from s 0 "(*") with Not_found -> s in CString.strip s -- cgit v1.2.3 From 6b78d0602d46520ed1bd0cfbef120de3b06ca826 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 23 Feb 2017 13:32:46 +0100 Subject: [safe-string] plugins/extraction No functional change. --- plugins/extraction/common.ml | 5 +---- plugins/extraction/scheme.ml | 6 +----- plugins/extraction/table.ml | 4 +--- 3 files changed, 3 insertions(+), 12 deletions(-) (limited to 'plugins') diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index de97ba97c..0a591e786 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -91,10 +91,7 @@ let begins_with_CoqXX s = let unquote s = if lang () != Scheme then s - else - let s = String.copy s in - for i=0 to String.length s - 1 do if s.[i] == '\'' then s.[i] <- '~' done; - s + else String.map (fun c -> if c == '\'' then '~' else c) s let rec qualify delim = function | [] -> assert false diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index a6309e61f..8d0cc4a0d 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -40,11 +40,7 @@ let preamble _ comment _ usf = (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ()) let pr_id id = - let s = Id.to_string id in - for i = 0 to String.length s - 1 do - if s.[i] == '\'' then s.[i] <- '~' - done; - str s + str @@ String.map (fun c -> if c == '\'' then '~' else c) (Id.to_string id) let paren = pp_par true diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 5e7d810c9..d6a334c5f 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -773,9 +773,7 @@ let file_of_modfile mp = | MPfile f -> Id.to_string (List.hd (DirPath.repr f)) | _ -> assert false in - let s = String.copy (string_of_modfile mp) in - if s.[0] != s0.[0] then s.[0] <- s0.[0]; - s + String.mapi (fun i c -> if i = 0 then s0.[0] else c) (string_of_modfile mp) let add_blacklist_entries l = blacklist_table := -- cgit v1.2.3 From 671e5ad1795b2606a5da9c65758fb0d337c4d14e Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 13 Mar 2017 23:06:33 +0100 Subject: Attempt to improve error message when "apply in" fail. - Adding a better location in the "apply" on the fly pattern. - Printing statement of lemma and of hypothesis. Was suggested by discussion at wish report #5390. --- intf/misctypes.mli | 2 +- plugins/ltac/g_tactic.ml4 | 5 +++-- plugins/ltac/tacintern.ml | 4 ++-- plugins/ltac/tacinterp.ml | 6 +++--- plugins/ltac/tacsubst.ml | 4 ++-- printing/miscprint.ml | 2 +- tactics/tactics.ml | 29 +++++++++++++++++++++-------- 7 files changed, 33 insertions(+), 19 deletions(-) (limited to 'plugins') diff --git a/intf/misctypes.mli b/intf/misctypes.mli index e4f595ac4..33dc2a335 100644 --- a/intf/misctypes.mli +++ b/intf/misctypes.mli @@ -28,7 +28,7 @@ and 'constr intro_pattern_action_expr = | IntroWildcard | IntroOrAndPattern of 'constr or_and_intro_pattern_expr | IntroInjection of (Loc.t * 'constr intro_pattern_expr) list - | IntroApplyOn of 'constr * (Loc.t * 'constr intro_pattern_expr) + | IntroApplyOn of (Loc.t * 'constr) * (Loc.t * 'constr intro_pattern_expr) | IntroRewrite of bool and 'constr or_and_intro_pattern_expr = | IntroOrPattern of (Loc.t * 'constr intro_pattern_expr) list list diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4 index 685c07c9a..fa01baab7 100644 --- a/plugins/ltac/g_tactic.ml4 +++ b/plugins/ltac/g_tactic.ml4 @@ -325,8 +325,9 @@ GEXTEND Gram l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> let loc0,pat = pat in let f c pat = - let loc = Loc.merge loc0 (Constrexpr_ops.constr_loc c) in - IntroAction (IntroApplyOn (c,(loc,pat))) in + let loc1 = Constrexpr_ops.constr_loc c in + let loc = Loc.merge loc0 loc1 in + IntroAction (IntroApplyOn ((loc1,c),(loc,pat))) in !@loc, List.fold_right f l pat ] ] ; simple_intropattern_closed: diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 1a8f26b26..3f83f104e 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -248,8 +248,8 @@ and intern_intro_pattern_action lf ist = function | IntroInjection l -> IntroInjection (List.map (intern_intro_pattern lf ist) l) | IntroWildcard | IntroRewrite _ as x -> x - | IntroApplyOn (c,pat) -> - IntroApplyOn (intern_constr ist c, intern_intro_pattern lf ist pat) + | IntroApplyOn ((loc,c),pat) -> + IntroApplyOn ((loc,intern_constr ist c), intern_intro_pattern lf ist pat) and intern_or_and_intro_pattern lf ist = function | IntroAndPattern l -> diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index aa646aa51..61a70d712 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -520,7 +520,7 @@ let rec intropattern_ids (loc,pat) = match pat with List.flatten (List.map intropattern_ids (List.flatten ll)) | IntroAction (IntroInjection l) -> List.flatten (List.map intropattern_ids l) - | IntroAction (IntroApplyOn (c,pat)) -> intropattern_ids pat + | IntroAction (IntroApplyOn ((_,c),pat)) -> intropattern_ids pat | IntroNaming (IntroAnonymous | IntroFresh _) | IntroAction (IntroWildcard | IntroRewrite _) | IntroForthcoming _ -> [] @@ -913,14 +913,14 @@ and interp_intro_pattern_action ist env sigma = function | IntroInjection l -> let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in sigma, IntroInjection l - | IntroApplyOn (c,ipat) -> + | IntroApplyOn ((loc,c),ipat) -> let c = { delayed = fun env sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma, c) = interp_open_constr ist env sigma c in Sigma.Unsafe.of_pair (c, sigma) } in let sigma,ipat = interp_intro_pattern ist env sigma ipat in - sigma, IntroApplyOn (c,ipat) + sigma, IntroApplyOn ((loc,c),ipat) | IntroWildcard | IntroRewrite _ as x -> sigma, x and interp_or_and_intro_pattern ist env sigma = function diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index b09bdda65..fe3a9f3b2 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -51,8 +51,8 @@ let rec subst_intro_pattern subst = function | loc, IntroNaming _ | loc, IntroForthcoming _ as x -> x and subst_intro_pattern_action subst = function - | IntroApplyOn (t,pat) -> - IntroApplyOn (subst_glob_constr subst t,subst_intro_pattern subst pat) + | IntroApplyOn ((loc,t),pat) -> + IntroApplyOn ((loc,subst_glob_constr subst t),subst_intro_pattern subst pat) | IntroOrAndPattern l -> IntroOrAndPattern (subst_intro_or_and_pattern subst l) | IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l) diff --git a/printing/miscprint.ml b/printing/miscprint.ml index 7b2c5695f..360843711 100644 --- a/printing/miscprint.ml +++ b/printing/miscprint.ml @@ -28,7 +28,7 @@ and pr_intro_pattern_action prc = function | IntroInjection pl -> str "[=" ++ hv 0 (prlist_with_sep spc (pr_intro_pattern prc) pl) ++ str "]" - | IntroApplyOn (c,pat) -> pr_intro_pattern prc pat ++ str "%" ++ prc c + | IntroApplyOn ((_,c),pat) -> pr_intro_pattern prc pat ++ str "%" ++ prc c | IntroRewrite true -> str "->" | IntroRewrite false -> str "<-" diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 6205bd109..84d09d833 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1815,24 +1815,37 @@ let find_matching_clause unifier clause = with NotExtensibleClause -> failwith "Cannot apply" in find clause +exception UnableToApply + let progress_with_clause flags innerclause clause = let ordered_metas = List.rev (clenv_independent clause) in - if List.is_empty ordered_metas then error "Statement without assumptions."; + if List.is_empty ordered_metas then raise UnableToApply; let f mv = try Some (find_matching_clause (clenv_fchain ~with_univs:false mv ~flags clause) innerclause) with Failure _ -> None in try List.find_map f ordered_metas - with Not_found -> error "Unable to unify." + with Not_found -> raise UnableToApply + +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_lconstr_env env sigma thm) ++ spc() ++ + str "on hypothesis of type" ++ brk(1,1) ++ + Pp.quote (Printer.pr_lconstr_env innerclause.env innerclause.evd (clenv_type innerclause)) ++ + str ".")) -let apply_in_once_main flags innerclause env sigma (d,lbind) = +let apply_in_once_main flags innerclause env sigma (loc,d,lbind) = let thm = nf_betaiota sigma (Retyping.get_type_of env sigma d) in let rec aux clause = try progress_with_clause flags innerclause clause with e when CErrors.noncritical e -> - let e = CErrors.push e in + let e' = CErrors.push e in try aux (clenv_push_prod clause) - with NotExtensibleClause -> iraise e + with NotExtensibleClause -> + match e with + | UnableToApply -> explain_unable_to_apply_lemma loc env sigma thm innerclause + | _ -> iraise e' in aux (make_clenv_binding env sigma (d,thm) lbind) @@ -1852,7 +1865,7 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in try - let clause = apply_in_once_main flags innerclause env sigma (c,lbind) in + let clause = apply_in_once_main flags innerclause env sigma (loc,c,lbind) in clenv_refine_in ~sidecond_first with_evars targetid id sigma clause (fun id -> Tacticals.New.tclTHENLIST [ @@ -2467,7 +2480,7 @@ and intro_pattern_action loc with_evars b style pat thin destopt 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 (f,(loc,pat)) -> + | IntroApplyOn ((loc',f),(loc,pat)) -> let naming,tac_ipat = prepare_intros_loc loc with_evars (IntroIdentifier id) destopt pat in let doclear = @@ -2479,7 +2492,7 @@ and intro_pattern_action loc with_evars b style pat thin destopt tac id = let Sigma (c, sigma, p) = f.delayed env sigma in Sigma ((c, NoBindings), sigma, p) } in - apply_in_delayed_once false true true with_evars naming id (None,(loc,f)) + 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 -- cgit v1.2.3 From 8c5adfd5acb883a3bc2850b6fc8c29d352a421f8 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 1 Jun 2016 17:52:39 +0200 Subject: [pp] Remove unused printing tagging infrastructure. Applications of it were not clear/unproven, it made printers more complex (as they needed to be functors) and as it lacked examples it confused some people. The printers now tag unconditionally, it is up to the backends to interpreted the tags. Tagging (and indeed the notion of rich document) should be reworked in a follow-up patch, so they are in sync, but this is a first step. Tested, test-suite passes. Notes: - We remove the `Richprinter` module. It was only used in the `annotate` IDE protocol call, its output was identical to the normal printer (or even inconsistent if taggers were not kept manually in sync). - Note that Richpp didn't need a single change. In particular, its main API entry point `Richpp.rich_pp` is not used by anyone. --- ide/ide_slave.ml | 7 +-- ide/richprinter.ml | 23 -------- ide/richprinter.mli | 36 ----------- plugins/ltac/pptactic.ml | 101 +++++++++---------------------- plugins/ltac/pptactic.mli | 70 +++++++++++++++++++--- plugins/ltac/pptacticsig.mli | 81 ------------------------- printing/ppannotation.ml | 33 ----------- printing/ppannotation.mli | 29 --------- printing/ppconstr.ml | 138 ++++++++++++++----------------------------- printing/ppconstr.mli | 86 +++++++++++++++++++++++++-- printing/ppconstrsig.mli | 95 ----------------------------- printing/ppvernac.ml | 35 ++--------- printing/ppvernac.mli | 15 +++-- printing/ppvernacsig.mli | 20 ------- printing/printing.mllib | 1 - printing/printmod.mli | 5 +- printing/printmodsig.mli | 17 ------ 17 files changed, 230 insertions(+), 562 deletions(-) delete mode 100644 ide/richprinter.ml delete mode 100644 ide/richprinter.mli delete mode 100644 plugins/ltac/pptacticsig.mli delete mode 100644 printing/ppannotation.ml delete mode 100644 printing/ppannotation.mli delete mode 100644 printing/ppconstrsig.mli delete mode 100644 printing/ppvernacsig.mli delete mode 100644 printing/printmodsig.mli (limited to 'plugins') diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 8a1f8c638..0cb8d377f 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -114,11 +114,8 @@ let annotate phrase = let pa = Pcoq.Gram.parsable (Stream.of_string phrase) in Vernac.parse_sentence (pa,None) in - let (_, xml) = - Richprinter.richpp_vernac ast - in - xml - + Richpp.repr (Richpp.richpp_of_pp (Ppvernac.pr_vernac ast)) + (** Goal display *) let hyp_next_tac sigma env decl = diff --git a/ide/richprinter.ml b/ide/richprinter.ml deleted file mode 100644 index 995cef1ac..000000000 --- a/ide/richprinter.ml +++ /dev/null @@ -1,23 +0,0 @@ -open Richpp - -module RichppConstr = Ppconstr.Richpp -module RichppVernac = Ppvernac.Richpp - -type rich_pp = - Ppannotation.t Richpp.located Xml_datatype.gxml - * Xml_datatype.xml - -let get_annotations obj = Pp.Tag.prj obj Ppannotation.tag - -let make_richpp pr ast = - let rich_pp = - rich_pp get_annotations (pr ast) - in - let xml = Ppannotation.( - xml_of_rich_pp tag_of_annotation attributes_of_annotation rich_pp - ) - in - (rich_pp, xml) - -let richpp_vernac = make_richpp RichppVernac.pr_vernac -let richpp_constr = make_richpp RichppConstr.pr_constr_expr diff --git a/ide/richprinter.mli b/ide/richprinter.mli deleted file mode 100644 index c9e84e3eb..000000000 --- a/ide/richprinter.mli +++ /dev/null @@ -1,36 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* rich_pp - -(** [richpp_constr constr] produces a rich pretty-printing of [constr]. *) -val richpp_constr : Constrexpr.constr_expr -> rich_pp diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 6f4ef37b4..9dacce28d 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -27,6 +27,33 @@ open Pputils open Ppconstr open Printer +module Tag = +struct + let keyword = + let style = Terminal.make ~bold:true () in + Ppstyle.make ~style ["tactic"; "keyword"] + + let primitive = + let style = Terminal.make ~fg_color:`LIGHT_GREEN () in + Ppstyle.make ~style ["tactic"; "primitive"] + + let string = + let style = Terminal.make ~fg_color:`LIGHT_RED () in + Ppstyle.make ~style ["tactic"; "string"] + +end + +let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s +let do_not_tag _ x = x +let tag_keyword = tag Tag.keyword +let tag_primitive = tag Tag.primitive +let tag_string = tag Tag.string +let tag_glob_tactic_expr = do_not_tag +let tag_glob_atomic_tactic_expr = do_not_tag +let tag_raw_tactic_expr = do_not_tag +let tag_raw_atomic_tactic_expr = do_not_tag +let tag_atomic_tactic_expr = do_not_tag + let pr_global x = Nametab.pr_global_env Id.Set.empty x type 'a grammar_tactic_prod_item_expr = @@ -64,30 +91,6 @@ type 'a extra_genarg_printer = (tolerability -> Val.t -> std_ppcmds) -> 'a -> std_ppcmds -module Make - (Ppconstr : Ppconstrsig.Pp) - (Taggers : sig - val tag_keyword - : std_ppcmds -> std_ppcmds - val tag_primitive - : std_ppcmds -> std_ppcmds - val tag_string - : std_ppcmds -> std_ppcmds - val tag_glob_tactic_expr - : glob_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_glob_atomic_tactic_expr - : glob_atomic_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_raw_tactic_expr - : raw_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_raw_atomic_tactic_expr - : raw_atomic_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_atomic_tactic_expr - : atomic_tactic_expr -> std_ppcmds -> std_ppcmds - end) -= struct - - open Taggers - let keyword x = tag_keyword (str x) let primitive x = tag_primitive (str x) @@ -1206,37 +1209,6 @@ module Make let pr_atomic_tactic env = pr_atomic_tactic_level env ltop -end - -module Tag = -struct - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["tactic"; "keyword"] - - let primitive = - let style = Terminal.make ~fg_color:`LIGHT_GREEN () in - Ppstyle.make ~style ["tactic"; "primitive"] - - let string = - let style = Terminal.make ~fg_color:`LIGHT_RED () in - Ppstyle.make ~style ["tactic"; "string"] - -end - -include Make (Ppconstr) (struct - let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s - let do_not_tag _ x = x - let tag_keyword = tag Tag.keyword - let tag_primitive = tag Tag.primitive - let tag_string = tag Tag.string - let tag_glob_tactic_expr = do_not_tag - let tag_glob_atomic_tactic_expr = do_not_tag - let tag_raw_tactic_expr = do_not_tag - let tag_raw_atomic_tactic_expr = do_not_tag - let tag_atomic_tactic_expr = do_not_tag -end) - let declare_extra_genarg_pprule wit (f : 'a raw_extra_genarg_printer) (g : 'b glob_extra_genarg_printer) @@ -1338,22 +1310,3 @@ let () = let pr_unit _ _ _ () = str "()" in let printer _ _ prtac = prtac (0, E) in declare_extra_genarg_pprule wit_ltac printer printer pr_unit - -module Richpp = struct - - include Make (Ppconstr.Richpp) (struct - open Ppannotation - open Genarg - let do_not_tag _ x = x - let tag e s = Pp.tag (Pp.Tag.inj e tag) s - let tag_keyword = tag AKeyword - let tag_primitive = tag AKeyword - let tag_string = do_not_tag () - let tag_glob_tactic_expr e = tag (AGlbGenArg (in_gen (glbwit wit_ltac) e)) - let tag_glob_atomic_tactic_expr = do_not_tag - let tag_raw_tactic_expr e = tag (ARawGenArg (in_gen (rawwit wit_ltac) e)) - let tag_raw_atomic_tactic_expr = do_not_tag - let tag_atomic_tactic_expr = do_not_tag - end) - -end diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 86e3ea548..43e22dba3 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -13,6 +13,8 @@ open Pp open Genarg open Geninterp open Names +open Misctypes +open Environ open Constrexpr open Tacexpr open Ppextend @@ -54,14 +56,66 @@ type pp_tactic = { val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit -(** The default pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as raw strings. *) -include Pptacticsig.Pp +val pr_with_occurrences : + ('a -> std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds +val pr_red_expr : + ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> + ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds +val pr_may_eval : + ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> + ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds + +val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds +val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds + +val pr_in_clause : + ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds + +val pr_clauses : bool option -> + ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds + +val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds + +val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds + +val pr_raw_extend: env -> int -> + ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds + +val pr_glob_extend: env -> int -> + ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds + +val pr_extend : + (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds + +val pr_alias_key : Names.KerName.t -> std_ppcmds + +val pr_alias : (Val.t -> std_ppcmds) -> + int -> Names.KerName.t -> Val.t list -> std_ppcmds + +val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds + +val pr_raw_tactic : raw_tactic_expr -> std_ppcmds + +val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds + +val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds + +val pr_atomic_tactic : env -> atomic_tactic_expr -> std_ppcmds + +val pr_hintbases : string list option -> std_ppcmds + +val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds + +val pr_bindings : + ('constr -> std_ppcmds) -> + ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds + +val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds + +val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> + ('b, 'a) match_rule -> std_ppcmds + +val pr_value : tolerability -> Val.t -> std_ppcmds -(** The rich pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as annotated strings. The annotations can be - retrieved using {!RichPp.rich_pp}. Their definitions are - located in {!Ppannotation.t}. *) -module Richpp : Pptacticsig.Pp val ltop : tolerability diff --git a/plugins/ltac/pptacticsig.mli b/plugins/ltac/pptacticsig.mli deleted file mode 100644 index 74ddd377a..000000000 --- a/plugins/ltac/pptacticsig.mli +++ /dev/null @@ -1,81 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds - val pr_red_expr : - ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> - ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds - val pr_may_eval : - ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> - ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds - - val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds - - val pr_in_clause : - ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds - - val pr_clauses : bool option -> - ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds - - val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds - - val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds - - val pr_raw_extend: env -> int -> - ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds - - val pr_glob_extend: env -> int -> - ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds - - val pr_extend : - (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds - - val pr_alias_key : Names.KerName.t -> std_ppcmds - - val pr_alias : (Val.t -> std_ppcmds) -> - int -> Names.KerName.t -> Val.t list -> std_ppcmds - - val pr_alias_key : Names.KerName.t -> std_ppcmds - - val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds - - val pr_raw_tactic : raw_tactic_expr -> std_ppcmds - - val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds - - val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds - - val pr_atomic_tactic : env -> atomic_tactic_expr -> std_ppcmds - - val pr_hintbases : string list option -> std_ppcmds - - val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds - - val pr_bindings : - ('constr -> std_ppcmds) -> - ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds - - val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds - - val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> - ('b, 'a) match_rule -> std_ppcmds - - val pr_value : tolerability -> Val.t -> std_ppcmds - -end diff --git a/printing/ppannotation.ml b/printing/ppannotation.ml deleted file mode 100644 index 726c0ffcf..000000000 --- a/printing/ppannotation.ml +++ /dev/null @@ -1,33 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* "keyword" - | AUnparsing _ -> "unparsing" - | AConstrExpr _ -> "constr_expr" - | AVernac _ -> "vernac_expr" - | AGlbGenArg _ -> "glob_generic_argument" - | ARawGenArg _ -> "raw_generic_argument" - -let attributes_of_annotation a = - [] - -let tag = Pp.Tag.create "ppannotation" diff --git a/printing/ppannotation.mli b/printing/ppannotation.mli deleted file mode 100644 index b0e0facef..000000000 --- a/printing/ppannotation.mli +++ /dev/null @@ -1,29 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* string - -val attributes_of_annotation : t -> (string * string) list - -val tag : t Pp.Tag.key diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 80ddd669f..b16384c60 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -21,18 +21,49 @@ open Decl_kinds open Misctypes (*i*) -module Make (Taggers : sig - val tag_keyword : std_ppcmds -> std_ppcmds - val tag_evar : std_ppcmds -> std_ppcmds - val tag_type : std_ppcmds -> std_ppcmds - val tag_path : std_ppcmds -> std_ppcmds - val tag_ref : std_ppcmds -> std_ppcmds - val tag_var : std_ppcmds -> std_ppcmds - val tag_constr_expr : constr_expr -> std_ppcmds -> std_ppcmds - val tag_unparsing : unparsing -> std_ppcmds -> std_ppcmds -end) = struct - - open Taggers +module Tag = +struct + let keyword = + let style = Terminal.make ~bold:true () in + Ppstyle.make ~style ["constr"; "keyword"] + + let evar = + let style = Terminal.make ~fg_color:`LIGHT_BLUE () in + Ppstyle.make ~style ["constr"; "evar"] + + let univ = + let style = Terminal.make ~bold:true ~fg_color:`YELLOW () in + Ppstyle.make ~style ["constr"; "type"] + + let notation = + let style = Terminal.make ~fg_color:`WHITE () in + Ppstyle.make ~style ["constr"; "notation"] + + let variable = + Ppstyle.make ["constr"; "variable"] + + let reference = + let style = Terminal.make ~fg_color:`LIGHT_GREEN () in + Ppstyle.make ~style ["constr"; "reference"] + + let path = + let style = Terminal.make ~fg_color:`LIGHT_MAGENTA () in + Ppstyle.make ~style ["constr"; "path"] +end + +let do_not_tag _ x = x +let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s +let tag_keyword = tag Tag.keyword +let tag_evar = tag Tag.evar +let tag_type = tag Tag.univ +let tag_unparsing = function +| UnpTerminal s -> tag Tag.notation +| _ -> do_not_tag () +let tag_constr_expr = do_not_tag +let tag_path = tag Tag.path +let tag_ref = tag Tag.reference +let tag_var = tag Tag.variable + let keyword s = tag_keyword (str s) let sep_v = fun _ -> str"," ++ spc() @@ -764,86 +795,3 @@ end) = struct let pr_binders = pr_undelimited_binders spc (pr ltop) -end - -module Tag = -struct - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["constr"; "keyword"] - - let evar = - let style = Terminal.make ~fg_color:`LIGHT_BLUE () in - Ppstyle.make ~style ["constr"; "evar"] - - let univ = - let style = Terminal.make ~bold:true ~fg_color:`YELLOW () in - Ppstyle.make ~style ["constr"; "type"] - - let notation = - let style = Terminal.make ~fg_color:`WHITE () in - Ppstyle.make ~style ["constr"; "notation"] - - let variable = - Ppstyle.make ["constr"; "variable"] - - let reference = - let style = Terminal.make ~fg_color:`LIGHT_GREEN () in - Ppstyle.make ~style ["constr"; "reference"] - - let path = - let style = Terminal.make ~fg_color:`LIGHT_MAGENTA () in - Ppstyle.make ~style ["constr"; "path"] - -end - -let do_not_tag _ x = x - -let split_token tag s = - let len = String.length s in - let rec parse_string off i = - if Int.equal i len then - if Int.equal off i then mt () else tag (str (String.sub s off (i - off))) - else if s.[i] == ' ' then - if Int.equal off i then parse_space 1 (succ i) - else tag (str (String.sub s off (i - off))) ++ parse_space 1 (succ i) - else parse_string off (succ i) - and parse_space spc i = - if Int.equal i len then str (String.make spc ' ') - else if s.[i] == ' ' then parse_space (succ spc) (succ i) - else str (String.make spc ' ') ++ parse_string i (succ i) - in - parse_string 0 0 - -(** Instantiating Make with tagging functions that only add style - information. *) -include Make (struct - let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s - let tag_keyword = tag Tag.keyword - let tag_evar = tag Tag.evar - let tag_type = tag Tag.univ - let tag_unparsing = function - | UnpTerminal s -> fun _ -> split_token (fun pp -> tag Tag.notation pp) s - | _ -> do_not_tag () - let tag_constr_expr = do_not_tag - let tag_path = tag Tag.path - let tag_ref = tag Tag.reference - let tag_var = tag Tag.variable -end) - -module Richpp = struct - - include Make (struct - open Ppannotation - let tag_keyword = Pp.tag (Pp.Tag.inj AKeyword tag) - let tag_type = Pp.tag (Pp.Tag.inj AKeyword tag) - let tag_evar = do_not_tag () - let tag_unparsing unp = Pp.tag (Pp.Tag.inj (AUnparsing unp) tag) - let tag_constr_expr e = Pp.tag (Pp.Tag.inj (AConstrExpr e) tag) - let tag_path = do_not_tag () - let tag_ref = do_not_tag () - let tag_var = do_not_tag () - end) - -end - diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index 0241633c6..a0106837a 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -11,11 +11,85 @@ (** The default pretty-printers produce {!Pp.std_ppcmds} that are interpreted as raw strings. *) -include Ppconstrsig.Pp +open Loc +open Pp +open Libnames +open Constrexpr +open Names +open Misctypes -(** The rich pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as annotated strings. The annotations can be - retrieved using {!RichPp.rich_pp}. Their definitions are - located in {!Ppannotation.t}. *) +val extract_lam_binders : + constr_expr -> local_binder list * constr_expr +val extract_prod_binders : + constr_expr -> local_binder list * constr_expr +val split_fix : + int -> constr_expr -> constr_expr -> + local_binder list * constr_expr * constr_expr -module Richpp : Ppconstrsig.Pp +val prec_less : int -> int * Ppextend.parenRelation -> bool + +val pr_tight_coma : unit -> std_ppcmds + +val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds + +val pr_lident : Id.t located -> std_ppcmds +val pr_lname : Name.t located -> std_ppcmds + +val pr_with_comments : Loc.t -> std_ppcmds -> std_ppcmds +val pr_com_at : int -> std_ppcmds +val pr_sep_com : + (unit -> std_ppcmds) -> + (constr_expr -> std_ppcmds) -> + constr_expr -> std_ppcmds + +val pr_id : Id.t -> std_ppcmds +val pr_name : Name.t -> std_ppcmds +val pr_qualid : qualid -> std_ppcmds +val pr_patvar : patvar -> std_ppcmds + +val pr_glob_level : glob_level -> std_ppcmds +val pr_glob_sort : glob_sort -> std_ppcmds +val pr_guard_annot : (constr_expr -> std_ppcmds) -> + local_binder list -> + ('a * Names.Id.t) option * recursion_order_expr -> + std_ppcmds + +val pr_record_body : (reference * constr_expr) list -> std_ppcmds +val pr_binders : local_binder list -> std_ppcmds +val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds +val pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds +val pr_constr_expr : constr_expr -> std_ppcmds +val pr_lconstr_expr : constr_expr -> std_ppcmds +val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds + +type term_pr = { + pr_constr_expr : constr_expr -> std_ppcmds; + pr_lconstr_expr : constr_expr -> std_ppcmds; + pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds; + pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds +} + +val set_term_pr : term_pr -> unit +val default_term_pr : term_pr + +(* The modular constr printer. + [modular_constr_pr pr s p t] prints the head of the term [t] and calls + [pr] on its subterms. + [s] is typically {!Pp.mt} and [p] is [lsimpleconstr] for "constr" printers + and [ltop] for "lconstr" printers (spiwack: we might need more + specification here). + We can make a new modular constr printer by overriding certain branches, + for instance if we want to build a printer which prints "Prop" as "Omega" + instead we can proceed as follows: + let my_modular_constr_pr pr s p = function + | CSort (_,GProp Null) -> str "Omega" + | t -> modular_constr_pr pr s p t + Which has the same type. We can turn a modular printer into a printer by + taking its fixpoint. *) + +type precedence +val lsimpleconstr : precedence +val ltop : precedence +val modular_constr_pr : + ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) -> + (unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds diff --git a/printing/ppconstrsig.mli b/printing/ppconstrsig.mli deleted file mode 100644 index 3de0d805c..000000000 --- a/printing/ppconstrsig.mli +++ /dev/null @@ -1,95 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* local_binder list * constr_expr - val extract_prod_binders : - constr_expr -> local_binder list * constr_expr - val split_fix : - int -> constr_expr -> constr_expr -> - local_binder list * constr_expr * constr_expr - - val prec_less : int -> int * Ppextend.parenRelation -> bool - - val pr_tight_coma : unit -> std_ppcmds - - val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds - - val pr_lident : Id.t located -> std_ppcmds - val pr_lname : Name.t located -> std_ppcmds - - val pr_with_comments : Loc.t -> std_ppcmds -> std_ppcmds - val pr_com_at : int -> std_ppcmds - val pr_sep_com : - (unit -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - constr_expr -> std_ppcmds - - val pr_id : Id.t -> std_ppcmds - val pr_name : Name.t -> std_ppcmds - val pr_qualid : qualid -> std_ppcmds - val pr_patvar : patvar -> std_ppcmds - - val pr_glob_level : glob_level -> std_ppcmds - val pr_glob_sort : glob_sort -> std_ppcmds - val pr_guard_annot : (constr_expr -> std_ppcmds) -> - local_binder list -> - ('a * Names.Id.t) option * recursion_order_expr -> - std_ppcmds - - val pr_record_body : (reference * constr_expr) list -> std_ppcmds - val pr_binders : local_binder list -> std_ppcmds - val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds - val pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds - val pr_constr_expr : constr_expr -> std_ppcmds - val pr_lconstr_expr : constr_expr -> std_ppcmds - val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds - - type term_pr = { - pr_constr_expr : constr_expr -> std_ppcmds; - pr_lconstr_expr : constr_expr -> std_ppcmds; - pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds; - pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds - } - - val set_term_pr : term_pr -> unit - val default_term_pr : term_pr - -(** The modular constr printer. - [modular_constr_pr pr s p t] prints the head of the term [t] and calls - [pr] on its subterms. - [s] is typically {!Pp.mt} and [p] is [lsimpleconstr] for "constr" printers - and [ltop] for "lconstr" printers (spiwack: we might need more - specification here). - We can make a new modular constr printer by overriding certain branches, - for instance if we want to build a printer which prints "Prop" as "Omega" - instead we can proceed as follows: - let my_modular_constr_pr pr s p = function - | CSort (_,GProp Null) -> str "Omega" - | t -> modular_constr_pr pr s p t - Which has the same type. We can turn a modular printer into a printer by - taking its fixpoint. *) - - type precedence - val lsimpleconstr : precedence - val ltop : precedence - val modular_constr_pr : - ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) -> - (unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds - -end - diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index ff72be90c..78ef4d4ba 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -19,17 +19,12 @@ open Constrexpr open Constrexpr_ops open Decl_kinds -module Make - (Ppconstr : Ppconstrsig.Pp) - (Taggers : sig - val tag_keyword : std_ppcmds -> std_ppcmds - val tag_vernac : vernac_expr -> std_ppcmds -> std_ppcmds - end) -= struct - - open Taggers open Ppconstr + let do_not_tag _ x = x + let tag_keyword = do_not_tag () + let tag_vernac = do_not_tag + let keyword s = tag_keyword (str s) let pr_constr = pr_constr_expr @@ -526,7 +521,7 @@ module Make let pr_using e = str (Proof_using.to_string e) let rec pr_vernac_body v = - let return = Taggers.tag_vernac v in + let return = tag_vernac v in match v with | VernacPolymorphic (poly, v) -> let s = if poly then keyword "Polymorphic" else keyword "Monomorphic" in @@ -1244,23 +1239,3 @@ module Make let pr_vernac v = try pr_vernac_body v ++ sep_end v with e -> CErrors.print e - -end - -include Make (Ppconstr) (struct - let do_not_tag _ x = x - let tag_keyword = do_not_tag () - let tag_vernac = do_not_tag -end) - -module Richpp = struct - - include Make - (Ppconstr.Richpp) - (struct - open Ppannotation - let tag_keyword s = Pp.tag (Pp.Tag.inj AKeyword tag) s - let tag_vernac v s = Pp.tag (Pp.Tag.inj (AVernac v) tag) s - end) - -end diff --git a/printing/ppvernac.mli b/printing/ppvernac.mli index d3d4a5ceb..836b05e0e 100644 --- a/printing/ppvernac.mli +++ b/printing/ppvernac.mli @@ -9,12 +9,11 @@ (** This module implements pretty-printers for vernac_expr syntactic objects and their subcomponents. *) -(** The default pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as raw strings. *) -include Ppvernacsig.Pp +(** Prints a fixpoint body *) +val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.std_ppcmds -(** The rich pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as annotated strings. The annotations can be - retrieved using {!RichPp.rich_pp}. Their definitions are - located in {!Ppannotation.t}. *) -module Richpp : Ppvernacsig.Pp +(** Prints a vernac expression *) +val pr_vernac_body : Vernacexpr.vernac_expr -> Pp.std_ppcmds + +(** Prints a vernac expression and closes it with a dot. *) +val pr_vernac : Vernacexpr.vernac_expr -> Pp.std_ppcmds diff --git a/printing/ppvernacsig.mli b/printing/ppvernacsig.mli deleted file mode 100644 index 5e5e4bcf4..000000000 --- a/printing/ppvernacsig.mli +++ /dev/null @@ -1,20 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.std_ppcmds - - (** Prints a vernac expression *) - val pr_vernac_body : Vernacexpr.vernac_expr -> Pp.std_ppcmds - - (** Prints a vernac expression and closes it with a dot. *) - val pr_vernac : Vernacexpr.vernac_expr -> Pp.std_ppcmds - -end diff --git a/printing/printing.mllib b/printing/printing.mllib index b0141b6d3..86b68d8fb 100644 --- a/printing/printing.mllib +++ b/printing/printing.mllib @@ -1,6 +1,5 @@ Genprint Pputils -Ppannotation Ppconstr Printer Printmod diff --git a/printing/printmod.mli b/printing/printmod.mli index 7f7d34392..f3079d5b6 100644 --- a/printing/printmod.mli +++ b/printing/printmod.mli @@ -6,9 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Pp open Names (** false iff the module is an element of an open module type *) val printable_body : DirPath.t -> bool -include Printmodsig.Pp +val pr_mutual_inductive_body : Environ.env -> mutual_inductive -> Declarations.mutual_inductive_body -> std_ppcmds +val print_module : bool -> module_path -> std_ppcmds +val print_modtype : module_path -> std_ppcmds diff --git a/printing/printmodsig.mli b/printing/printmodsig.mli deleted file mode 100644 index f71fffdce..000000000 --- a/printing/printmodsig.mli +++ /dev/null @@ -1,17 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* mutual_inductive -> Declarations.mutual_inductive_body -> std_ppcmds - val print_module : bool -> module_path -> std_ppcmds - val print_modtype : module_path -> std_ppcmds -end -- cgit v1.2.3 From 14155762a7cd46ed6a3e9cf2a58e11ee1244b188 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 1 Jun 2016 18:31:05 +0200 Subject: [pp] Replace `Pp.Tag` by `Ppstyle.tag` = `string list` This is what has always been used, so it doesn't represent a functional change. This is just a preliminary patch, but many more possibilities could be done wrt tags. --- lib/cErrors.ml | 4 ++-- lib/feedback.ml | 10 +++++----- lib/pp.ml | 24 +++--------------------- lib/pp.mli | 26 +++++--------------------- lib/ppstyle.ml | 36 ++++++++++++++++++------------------ lib/ppstyle.mli | 20 +++++++++----------- lib/richpp.ml | 5 +---- lib/richpp.mli | 2 +- parsing/cLexer.ml4 | 2 +- plugins/ltac/pptactic.ml | 2 +- printing/ppconstr.ml | 2 +- printing/printmod.ml | 40 ++++++++++++++++------------------------ toplevel/coqloop.ml | 4 ++-- toplevel/vernac.ml | 2 +- vernac/explainErr.ml | 2 +- 15 files changed, 67 insertions(+), 114 deletions(-) (limited to 'plugins') diff --git a/lib/cErrors.ml b/lib/cErrors.ml index dbebe6a48..9cbc3fb6d 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -22,7 +22,7 @@ exception Anomaly of string option * std_ppcmds (* System errors *) * Anyways, tagging should not happen here, but in the specific * listener to the msg_* stuff. *) -let tag_err_str s = tag Ppstyle.(Tag.inj error_tag tag) (str s) ++ spc () +let tag_err_str s = tag Ppstyle.error_tag (str s) ++ spc () let err_str = tag_err_str "Error:" let ann_str = tag_err_str "Anomaly:" @@ -154,6 +154,6 @@ let handled e = let fatal_error info anomaly = let msg = info ++ fnl () in - pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft msg; + pp_with !Pp_control.err_ft msg; Format.pp_print_flush !Pp_control.err_ft (); exit (if anomaly then 129 else 1) diff --git a/lib/feedback.ml b/lib/feedback.ml index 57c6f30a4..e723bf4ba 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -73,10 +73,10 @@ end open Emacs -let dbg_str = tag Ppstyle.(Tag.inj debug_tag tag) (str "Debug:") ++ spc () +let dbg_str = tag Ppstyle.debug_tag (str "Debug:") ++ spc () let info_str = mt () -let warn_str = tag Ppstyle.(Tag.inj warning_tag tag) (str "Warning:") ++ spc () -let err_str = tag Ppstyle.(Tag.inj error_tag tag) (str "Error:" ) ++ spc () +let warn_str = tag Ppstyle.warning_tag (str "Warning:") ++ spc () +let err_str = tag Ppstyle.error_tag (str "Error:" ) ++ spc () let make_body quoter info ?loc s = let loc = Option.cata Pp.pr_loc (Pp.mt ()) loc in @@ -132,7 +132,7 @@ let make_style_stack () = | st :: _ -> st in let push tag = - let style = match Ppstyle.get_style tag with + let style = match Ppstyle.get_style_format tag with | None -> empty | Some st -> st in @@ -156,7 +156,7 @@ let init_color_output () = let open Pp_control in let push_tag, pop_tag, clear_tag = make_style_stack () in std_logger_cleanup := clear_tag; - std_logger_tag := Some Ppstyle.pp_tag; + std_logger_tag := Some Ppstyle.to_format; let tag_handler = { Format.mark_open_tag = push_tag; Format.mark_close_tag = pop_tag; diff --git a/lib/pp.ml b/lib/pp.ml index a51b4458f..57d630a69 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -42,25 +42,7 @@ end = struct end -module Tag : -sig - type t - type 'a key - val create : string -> 'a key - val inj : 'a -> 'a key -> t - val prj : t -> 'a key -> 'a option -end = -struct - -module Dyn = Dyn.Make(struct end) - -type t = Dyn.t -type 'a key = 'a Dyn.tag -let create = Dyn.create -let inj = Dyn.Easy.inj -let prj = Dyn.Easy.prj - -end +type pp_tag = string list open Pp_control @@ -95,7 +77,7 @@ type 'a ppcmd_token = | Ppcmd_open_box of block_type | Ppcmd_close_box | Ppcmd_comment of string list - | Ppcmd_open_tag of Tag.t + | Ppcmd_open_tag of pp_tag | Ppcmd_close_tag type 'a ppdir_token = @@ -243,7 +225,7 @@ let rec pr_com ft s = Some s2 -> Format.pp_force_newline ft (); pr_com ft s2 | None -> () -type tag_handler = Tag.t -> Format.tag +type tag_handler = pp_tag -> Format.tag (* pretty printing functions *) let pp_dirs ?pp_tag ft = diff --git a/lib/pp.mli b/lib/pp.mli index f17908262..64ebea196 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -67,27 +67,11 @@ val close : unit -> std_ppcmds (** {6 Opening and closing of tags} *) -module Tag : -sig - type t - (** Type of tags. Tags are dynamic types comparable to {Dyn.t}. *) +(* XXX: Improve and add attributes *) +type pp_tag = string list - type 'a key - (** Keys used to inject tags *) - - val create : string -> 'a key - (** Create a key with the given name. Two keys cannot share the same name, if - ever this is the case this function raises an assertion failure. *) - - val inj : 'a -> 'a key -> t - (** Inject an object into a tag. *) - - val prj : t -> 'a key -> 'a option - (** Project an object from a tag. *) -end - -val tag : Tag.t -> std_ppcmds -> std_ppcmds -val open_tag : Tag.t -> std_ppcmds +val tag : pp_tag -> std_ppcmds -> std_ppcmds +val open_tag : pp_tag -> std_ppcmds val close_tag : unit -> std_ppcmds (** {6 Utilities} *) @@ -165,7 +149,7 @@ val pr_loc : Loc.t -> std_ppcmds (** {6 Low-level pretty-printing functions with and without flush} *) (** FIXME: These ignore the logging settings and call [Format] directly *) -type tag_handler = Tag.t -> Format.tag +type tag_handler = pp_tag -> Format.tag (** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and flush [fmt] *) val msg_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit diff --git a/lib/ppstyle.ml b/lib/ppstyle.ml index aa47c5167..298e3be6b 100644 --- a/lib/ppstyle.ml +++ b/lib/ppstyle.ml @@ -8,32 +8,38 @@ module String = CString -type t = string -(** We use the concatenated string, with dots separating each string. We - forbid the use of dots in the strings. *) +type t = Pp.pp_tag let tags : Terminal.style option String.Map.t ref = ref String.Map.empty +let to_format tag = String.concat "." tag +let of_format tag = String.split '.' tag + let make ?style tag = - let check s = if String.contains s '.' then invalid_arg "Ppstyle.make" in - let () = List.iter check tag in - let name = String.concat "." tag in + let name = to_format tag in let () = assert (not (String.Map.mem name !tags)) in - let () = tags := String.Map.add name style !tags in - name + let () = tags := String.Map.add name style !tags in + tag -let repr t = String.split '.' t +let repr t = t let get_style tag = - try String.Map.find tag !tags with Not_found -> assert false + try String.Map.find (to_format tag) !tags + with Not_found -> assert false + +let get_style_format tag = + try String.Map.find tag !tags + with Not_found -> assert false let set_style tag st = - try tags := String.Map.update tag st !tags with Not_found -> assert false + try tags := String.Map.update (to_format tag) st !tags + with Not_found -> assert false let clear_styles () = tags := String.Map.map (fun _ -> None) !tags -let dump () = String.Map.bindings !tags +let dump () = + List.map (fun (s,b) -> (String.split '.' s, b)) (String.Map.bindings !tags) let parse_config s = let styles = Terminal.parse s in @@ -42,8 +48,6 @@ let parse_config s = in tags := List.fold_left set !tags styles -let tag = Pp.Tag.create "ppstyle" - (** Default tag is to reset everything *) let default = Terminal.({ fg_color = Some `DEFAULT; @@ -67,7 +71,3 @@ let warning_tag = let debug_tag = let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`MAGENTA () in make ~style ["message"; "debug"] - -let pp_tag t = match Pp.Tag.prj t tag with -| None -> "" -| Some key -> key diff --git a/lib/ppstyle.mli b/lib/ppstyle.mli index d9fd75765..b9422f7cf 100644 --- a/lib/ppstyle.mli +++ b/lib/ppstyle.mli @@ -11,7 +11,11 @@ (** {5 Style tags} *) -type t = string +(** This API is provisional and will likely be refined. *) +type t = Pp.pp_tag + +val to_format : t -> Format.tag +val of_format : Format.tag -> t (** Style tags *) @@ -23,14 +27,15 @@ val repr : t -> string list (** Gives back the original name of the style tag where each string has been concatenated and separated with a dot. *) -val tag : t Pp.Tag.key -(** An annotation for styles *) - (** {5 Manipulating global styles} *) val get_style : t -> Terminal.style option (** Get the style associated to a tag. *) +val get_style_format : Format.tag -> Terminal.style option +(** Get the style associated to a tag from a format tag. *) + + val set_style : t -> Terminal.style option -> unit (** Set a style associated to a tag. *) @@ -44,13 +49,6 @@ val parse_config : string -> unit val dump : unit -> (t * Terminal.style option) list (** Recover the list of known tags together with their current style. *) -(** {5 Color output} *) - -val pp_tag : Pp.tag_handler -(** Returns the name of a style tag that is understandable by the formatters - that have been inititialized through {!init_color_output}. To be used with - {!Pp.pp_with}. *) - (** {5 Tags} *) val error_tag : t diff --git a/lib/richpp.ml b/lib/richpp.ml index d1c6d158e..c0128dbc2 100644 --- a/lib/richpp.ml +++ b/lib/richpp.ml @@ -177,10 +177,7 @@ let richpp_of_xml xml = xml let richpp_of_string s = PCData s let richpp_of_pp pp = - let annotate t = match Pp.Tag.prj t Ppstyle.tag with - | None -> None - | Some key -> Some (Ppstyle.repr key) - in + let annotate t = Some (Ppstyle.repr t) in let rec drop = function | PCData s -> [PCData s] | Element (_, annotation, cs) -> diff --git a/lib/richpp.mli b/lib/richpp.mli index 287d265a8..2e839e996 100644 --- a/lib/richpp.mli +++ b/lib/richpp.mli @@ -22,7 +22,7 @@ type 'annotation located = { The [get_annotations] function is used to convert tags into the desired annotation. *) val rich_pp : - (Pp.Tag.t -> 'annotation option) -> Pp.std_ppcmds -> + (Pp.pp_tag -> 'annotation option) -> Pp.std_ppcmds -> 'annotation located Xml_datatype.gxml (** [annotations_positions ssdoc] returns a list associating each diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index 72bd11e03..a637d2e43 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -105,7 +105,7 @@ module Error = struct Printf.sprintf "Unsupported Unicode character (0x%x)" x) (* Require to fix the Camlp4 signature *) - let print ppf x = Pp.pp_with ~pp_tag:Ppstyle.pp_tag ppf (Pp.str (to_string x)) + let print ppf x = Pp.pp_with ~pp_tag:Ppstyle.to_format ppf (Pp.str (to_string x)) end open Error diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 9dacce28d..d9410a088 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -43,7 +43,7 @@ struct end -let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s +let tag t s = Pp.tag t s let do_not_tag _ x = x let tag_keyword = tag Tag.keyword let tag_primitive = tag Tag.primitive diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index b16384c60..c772f7be1 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -52,7 +52,7 @@ struct end let do_not_tag _ x = x -let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s +let tag t s = Pp.tag t s let tag_keyword = tag Tag.keyword let tag_evar = tag Tag.evar let tag_type = tag Tag.univ diff --git a/printing/printmod.ml b/printing/printmod.ml index dfa66d437..ac7ff7697 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -26,6 +26,20 @@ open Goptions the "short" mode or (Some env) in the "rich" one. *) +module Tag = +struct + let definition = + let style = Terminal.make ~bold:true ~fg_color:`LIGHT_RED () in + Ppstyle.make ~style ["module"; "definition"] + let keyword = + let style = Terminal.make ~bold:true () in + Ppstyle.make ~style ["module"; "keyword"] +end + +let tag t s = Pp.tag t s +let tag_definition s = tag Tag.definition s +let tag_keyword s = tag Tag.keyword s + let short = ref false let _ = @@ -44,14 +58,8 @@ let mk_fake_top = let r = ref 0 in fun () -> incr r; Id.of_string ("FAKETOP"^(string_of_int !r)) -module Make (Taggers : sig - val tag_definition : std_ppcmds -> std_ppcmds - val tag_keyword : std_ppcmds -> std_ppcmds -end) = -struct - -let def s = Taggers.tag_definition (str s) -let keyword s = Taggers.tag_keyword (str s) +let def s = tag_definition (str s) +let keyword s = tag_keyword (str s) let get_new_id locals id = let rec get_id l id = @@ -441,20 +449,4 @@ let print_modtype kn = with e when CErrors.noncritical e -> print_signature' true None kn mtb.mod_type)) -end - -module Tag = -struct - let definition = - let style = Terminal.make ~bold:true ~fg_color:`LIGHT_RED () in - Ppstyle.make ~style ["module"; "definition"] - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["module"; "keyword"] -end -include Make(struct - let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s - let tag_definition s = tag Tag.definition s - let tag_keyword s = tag Tag.keyword s -end) diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 0dfd06726..5521e8a40 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -13,7 +13,7 @@ open Flags open Vernac open Pcoq -let top_stderr x = msg_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft x +let top_stderr x = msg_with ~pp_tag:Ppstyle.to_format !Pp_control.err_ft x (* A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) @@ -309,7 +309,7 @@ let do_vernac () = | any -> let any = CErrors.push any in let msg = print_toplevel_error any ++ fnl () in - pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft msg; + pp_with !Pp_control.std_ft msg; Format.pp_print_flush !Pp_control.std_ft () (** Main coq loop : read vernacular expressions until Drop is entered. diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index b73321c00..de7bc6929 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -179,7 +179,7 @@ let pp_cmd_header loc com = and take control of the console. *) let print_cmd_header loc com = - Pp.pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft (pp_cmd_header loc com); + Pp.pp_with ~pp_tag:Ppstyle.to_format !Pp_control.std_ft (pp_cmd_header loc com); Format.pp_print_flush !Pp_control.std_ft () let rec interp_vernac po chan_beautify checknav (loc,com) = diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 17897460c..148d029bc 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -47,7 +47,7 @@ let _ = CErrors.register_handler explain_exn_default let wrap_vernac_error with_header (exn, info) strm = if with_header then - let header = Pp.tag (Pp.Tag.inj Ppstyle.error_tag Ppstyle.tag) (str "Error:") in + let header = Pp.tag Ppstyle.error_tag (str "Error:") in let e = EvaluatedError (hov 0 (header ++ spc () ++ strm), None) in (e, info) else -- cgit v1.2.3 From 2617a83e572531e26734cff8b9eb8aa09d49b850 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 27 Sep 2016 16:33:47 +0200 Subject: [pp] Remove `Pp.stras`. Mostly unused, we ought to limit spacing in the boxes themselves. --- lib/pp.ml | 34 ++++++++++++---------------------- lib/pp.mli | 1 - plugins/extraction/common.ml | 4 +++- 3 files changed, 15 insertions(+), 24 deletions(-) (limited to 'plugins') diff --git a/lib/pp.ml b/lib/pp.ml index 57d630a69..9d2445d49 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -58,18 +58,14 @@ open Pp_control *) type block_type = - | Pp_hbox of int - | Pp_vbox of int - | Pp_hvbox of int + | Pp_hbox of int + | Pp_vbox of int + | Pp_hvbox of int | Pp_hovbox of int -type str_token = -| Str_def of string -| Str_len of string * int (** provided length *) - -type 'a ppcmd_token = - | Ppcmd_print of 'a - | Ppcmd_box of block_type * ('a ppcmd_token Glue.t) +type ppcmd_token = + | Ppcmd_string of string + | Ppcmd_box of block_type * (ppcmd_token Glue.t) | Ppcmd_print_break of int * int | Ppcmd_white_space of int | Ppcmd_force_newline @@ -81,11 +77,11 @@ type 'a ppcmd_token = | Ppcmd_close_tag type 'a ppdir_token = - | Ppdir_ppcmds of 'a ppcmd_token Glue.t + | Ppdir_ppcmds of ppcmd_token Glue.t | Ppdir_print_newline | Ppdir_print_flush -type ppcmd = str_token ppcmd_token +type ppcmd = ppcmd_token type std_ppcmds = ppcmd Glue.t @@ -134,8 +130,7 @@ let utf8_length s = !cnt (* formatting commands *) -let str s = Glue.atom(Ppcmd_print (Str_def s)) -let stras (i, s) = Glue.atom(Ppcmd_print (Str_len (s, i))) +let str s = Glue.atom(Ppcmd_string s) let brk (a,b) = Glue.atom(Ppcmd_print_break (a,b)) let fnl () = Glue.atom(Ppcmd_force_newline) let pifb () = Glue.atom(Ppcmd_print_if_broken) @@ -236,14 +231,9 @@ let pp_dirs ?pp_tag ft = | Pp_hovbox n -> Format.pp_open_hovbox ft n in let rec pp_cmd = function - | Ppcmd_print tok -> - begin match tok with - | Str_def s -> - let n = utf8_length s in - Format.pp_print_as ft n s - | Str_len (s, n) -> - Format.pp_print_as ft n s - end + | Ppcmd_string str -> + let n = utf8_length str in + Format.pp_print_as ft n str | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *) pp_open_box bty ; if not (Format.over_max_boxes ()) then Glue.iter pp_cmd ss; diff --git a/lib/pp.mli b/lib/pp.mli index 64ebea196..82accfff3 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -13,7 +13,6 @@ type std_ppcmds (** {6 Formatting commands} *) val str : string -> std_ppcmds -val stras : int * string -> std_ppcmds val brk : int * int -> std_ppcmds val fnl : unit -> std_ppcmds val pifb : unit -> std_ppcmds diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 0a591e786..fc8d5356c 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -67,7 +67,9 @@ let pp_boxed_tuple f = function blocks is less that a line length. To avoid this awkward situation, we attach a big virtual size to [fnl] newlines. *) -let fnl () = stras (1000000,"") ++ fnl () +(* EG: This looks quite suspicious... but beware of bugs *) +(* let fnl () = stras (1000000,"") ++ fnl () *) +let fnl () = fnl () let fnl2 () = fnl () ++ fnl () -- cgit v1.2.3 From 8f8af9e4ebf1ea1ed15f765196ef5af8a77d3c27 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 29 Sep 2016 16:06:43 +0200 Subject: [pp] Prepare for serialization, remove opaque glue. We also remove flushing operations `msg_with`, now the flushing responsibility belong to the owner of the formatter. --- lib/feedback.ml | 4 +- lib/pp.ml | 184 +++++++++++++++----------------------------- lib/pp.mli | 21 +---- plugins/extraction/ocaml.ml | 8 +- printing/printer.ml | 2 +- printing/printmod.ml | 4 +- toplevel/coqloop.ml | 4 +- toplevel/coqtop.ml | 2 +- toplevel/vernac.ml | 3 +- vernac/explainErr.ml | 2 +- 10 files changed, 83 insertions(+), 151 deletions(-) (limited to 'plugins') diff --git a/lib/feedback.ml b/lib/feedback.ml index e723bf4ba..971a51e35 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -51,7 +51,9 @@ open Pp_control type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit -let msgnl_with ?pp_tag fmt strm = msg_with ?pp_tag fmt (strm ++ fnl ()) +let msgnl_with ?pp_tag fmt strm = + pp_with ?pp_tag fmt (strm ++ fnl ()); + Format.pp_print_flush fmt () (* XXX: This is really painful! *) module Emacs = struct diff --git a/lib/pp.ml b/lib/pp.ml index 9d2445d49..6d7bdf75e 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -6,44 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -module Glue : sig - - (** The [Glue] module implements a container data structure with - efficient concatenation. *) - - type 'a t - - val atom : 'a -> 'a t - val glue : 'a t -> 'a t -> 'a t - val empty : 'a t - val is_empty : 'a t -> bool - val iter : ('a -> unit) -> 'a t -> unit - -end = struct - - type 'a t = GEmpty | GLeaf of 'a | GNode of 'a t * 'a t - - let atom x = GLeaf x - - let glue x y = - match x, y with - | GEmpty, _ -> y - | _, GEmpty -> x - | _, _ -> GNode (x,y) - - let empty = GEmpty - - let is_empty x = x = GEmpty - - let rec iter f = function - | GEmpty -> () - | GLeaf x -> f x - | GNode (x,y) -> iter f x; iter f y - -end - -type pp_tag = string list - open Pp_control (* The different kinds of blocks are: @@ -63,36 +25,22 @@ type block_type = | Pp_hvbox of int | Pp_hovbox of int -type ppcmd_token = +type pp_tag = string list + +type std_ppcmds = + | Ppcmd_empty | Ppcmd_string of string - | Ppcmd_box of block_type * (ppcmd_token Glue.t) + | Ppcmd_glue of std_ppcmds * std_ppcmds + | Ppcmd_box of block_type * std_ppcmds | Ppcmd_print_break of int * int | Ppcmd_white_space of int | Ppcmd_force_newline - | Ppcmd_print_if_broken | Ppcmd_open_box of block_type | Ppcmd_close_box | Ppcmd_comment of string list | Ppcmd_open_tag of pp_tag | Ppcmd_close_tag -type 'a ppdir_token = - | Ppdir_ppcmds of ppcmd_token Glue.t - | Ppdir_print_newline - | Ppdir_print_flush - -type ppcmd = ppcmd_token - -type std_ppcmds = ppcmd Glue.t - -type 'a ppdirs = 'a ppdir_token Glue.t - -let (++) = Glue.glue - -let app = Glue.glue - -let is_empty g = Glue.is_empty g - (* Compute length of an UTF-8 encoded string Rem 1 : utf8_length <= String.length (equal if pure ascii) Rem 2 : if used for an iso8859_1 encoded string, the result is @@ -129,22 +77,30 @@ let utf8_length s = done ; !cnt +let app s1 s2 = match s1, s2 with + | Ppcmd_empty, s + | s, Ppcmd_empty -> s + | s1, s2 -> Ppcmd_glue(s1, s2) + +let (++) = app + (* formatting commands *) -let str s = Glue.atom(Ppcmd_string s) -let brk (a,b) = Glue.atom(Ppcmd_print_break (a,b)) -let fnl () = Glue.atom(Ppcmd_force_newline) -let pifb () = Glue.atom(Ppcmd_print_if_broken) -let ws n = Glue.atom(Ppcmd_white_space n) -let comment l = Glue.atom(Ppcmd_comment l) +let str s = Ppcmd_string s +let brk (a,b) = Ppcmd_print_break (a,b) +let fnl () = Ppcmd_force_newline +let ws n = Ppcmd_white_space n +let comment l = Ppcmd_comment l (* derived commands *) -let mt () = Glue.empty -let spc () = Glue.atom(Ppcmd_print_break (1,0)) -let cut () = Glue.atom(Ppcmd_print_break (0,0)) -let align () = Glue.atom(Ppcmd_print_break (0,0)) -let int n = str (string_of_int n) -let real r = str (string_of_float r) -let bool b = str (string_of_bool b) +let mt () = Ppcmd_empty +let spc () = Ppcmd_print_break (1,0) +let cut () = Ppcmd_print_break (0,0) +let align () = Ppcmd_print_break (0,0) +let int n = str (string_of_int n) +let real r = str (string_of_float r) +let bool b = str (string_of_bool b) + +(* XXX: To Remove *) let strbrk s = let rec aux p n = if n < String.length s then @@ -153,7 +109,7 @@ let strbrk s = else str (String.sub s p (n-p)) :: spc () :: aux (n+1) (n+1) else aux p (n + 1) else if p = n then [] else [str (String.sub s p (n-p))] - in List.fold_left (++) Glue.empty (aux 0 0) + in List.fold_left (++) Ppcmd_empty (aux 0 0) let pr_loc_pos loc = if Loc.is_ghost loc then (str"") @@ -174,26 +130,25 @@ let pr_loc loc = int (loc.bp-loc.bol_pos) ++ str"-" ++ int (loc.ep-loc.bol_pos) ++ str":" ++ fnl()) -let ismt = is_empty +let ismt = function | Ppcmd_empty -> true | _ -> false (* boxing commands *) -let h n s = Glue.atom(Ppcmd_box(Pp_hbox n,s)) -let v n s = Glue.atom(Ppcmd_box(Pp_vbox n,s)) -let hv n s = Glue.atom(Ppcmd_box(Pp_hvbox n,s)) -let hov n s = Glue.atom(Ppcmd_box(Pp_hovbox n,s)) +let h n s = Ppcmd_box(Pp_hbox n,s) +let v n s = Ppcmd_box(Pp_vbox n,s) +let hv n s = Ppcmd_box(Pp_hvbox n,s) +let hov n s = Ppcmd_box(Pp_hovbox n,s) (* Opening and closing of boxes *) -let hb n = Glue.atom(Ppcmd_open_box(Pp_hbox n)) -let vb n = Glue.atom(Ppcmd_open_box(Pp_vbox n)) -let hvb n = Glue.atom(Ppcmd_open_box(Pp_hvbox n)) -let hovb n = Glue.atom(Ppcmd_open_box(Pp_hovbox n)) -let close () = Glue.atom(Ppcmd_close_box) +let hb n = Ppcmd_open_box(Pp_hbox n) +let vb n = Ppcmd_open_box(Pp_vbox n) +let hvb n = Ppcmd_open_box(Pp_hvbox n) +let hovb n = Ppcmd_open_box(Pp_hovbox n) +let close () = Ppcmd_close_box (* Opening and closed of tags *) -let open_tag t = Glue.atom(Ppcmd_open_tag t) -let close_tag () = Glue.atom(Ppcmd_close_tag) +let open_tag t = Ppcmd_open_tag t +let close_tag () = Ppcmd_close_tag let tag t s = open_tag t ++ s ++ close_tag () -let eval_ppcmds l = l (* In new syntax only double quote char is escaped by repeating it *) let escape_string s = @@ -223,27 +178,27 @@ let rec pr_com ft s = type tag_handler = pp_tag -> Format.tag (* pretty printing functions *) -let pp_dirs ?pp_tag ft = - let pp_open_box = function +let pp_with ?pp_tag ft = + let cpp_open_box = function | Pp_hbox n -> Format.pp_open_hbox ft () | Pp_vbox n -> Format.pp_open_vbox ft n | Pp_hvbox n -> Format.pp_open_hvbox ft n | Pp_hovbox n -> Format.pp_open_hovbox ft n in - let rec pp_cmd = function - | Ppcmd_string str -> - let n = utf8_length str in - Format.pp_print_as ft n str + let rec pp_cmd = let open Format in function + | Ppcmd_empty -> () + | Ppcmd_glue(s1,s2) -> pp_cmd s1; pp_cmd s2 + | Ppcmd_string str -> let n = utf8_length str in + pp_print_as ft n str | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *) - pp_open_box bty ; - if not (Format.over_max_boxes ()) then Glue.iter pp_cmd ss; + cpp_open_box bty ; + if not (Format.over_max_boxes ()) then pp_cmd ss; Format.pp_close_box ft () - | Ppcmd_open_box bty -> pp_open_box bty - | Ppcmd_close_box -> Format.pp_close_box ft () - | Ppcmd_white_space n -> Format.pp_print_break ft n 0 - | Ppcmd_print_break(m,n) -> Format.pp_print_break ft m n - | Ppcmd_force_newline -> Format.pp_force_newline ft () - | Ppcmd_print_if_broken -> Format.pp_print_if_newline ft () + | Ppcmd_open_box bty -> cpp_open_box bty + | Ppcmd_close_box -> pp_close_box ft () + | Ppcmd_white_space n -> pp_print_break ft n 0 + | Ppcmd_print_break(m,n) -> pp_print_break ft m n + | Ppcmd_force_newline -> pp_force_newline ft () | Ppcmd_comment coms -> List.iter (pr_com ft) coms | Ppcmd_open_tag tag -> begin match pp_tag with @@ -256,34 +211,19 @@ let pp_dirs ?pp_tag ft = | Some _ -> Format.pp_close_tag ft () end in - let pp_dir = function - | Ppdir_ppcmds cmdstream -> Glue.iter pp_cmd cmdstream - | Ppdir_print_newline -> Format.pp_print_newline ft () - | Ppdir_print_flush -> Format.pp_print_flush ft () - in - fun (dirstream : _ ppdirs) -> - try - Glue.iter pp_dir dirstream - with reraise -> - let reraise = Backtrace.add_backtrace reraise in - let () = Format.pp_print_flush ft () in - Exninfo.iraise reraise - -(* pretty printing functions WITHOUT FLUSH *) -let pp_with ?pp_tag ft strm = - pp_dirs ?pp_tag ft (Glue.atom (Ppdir_ppcmds strm)) - -(* pretty printing functions WITH FLUSH *) -let msg_with ?pp_tag ft strm = - pp_dirs ?pp_tag ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_flush)) + try pp_cmd + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + let () = Format.pp_print_flush ft () in + Exninfo.iraise reraise (* If mixing some output and a goal display, please use msg_warning, so that interfaces (proofgeneral for example) can easily dispatch them to different windows. *) (** Output to a string formatter *) -let string_of_ppcmds c = - Format.fprintf Format.str_formatter "@[%a@]" (msg_with ?pp_tag:None) c; +let string_of_ppcmds ?pp_tag c = + Format.fprintf Format.str_formatter "@[%a@]" (pp_with ?pp_tag) c; Format.flush_str_formatter () (* Copy paste from Util *) @@ -310,7 +250,7 @@ let pr_nth n = (* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *) -let prlist pr l = List.fold_left (fun x e -> x ++ pr e) Glue.empty l +let prlist pr l = List.fold_left (fun x e -> x ++ pr e) Ppcmd_empty l (* unlike all other functions below, [prlist] works lazily. if a strict behavior is needed, use [prlist_strict] instead. diff --git a/lib/pp.mli b/lib/pp.mli index 82accfff3..f61261a17 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -15,7 +15,6 @@ type std_ppcmds val str : string -> std_ppcmds val brk : int * int -> std_ppcmds val fnl : unit -> std_ppcmds -val pifb : unit -> std_ppcmds val ws : int -> std_ppcmds val mt : unit -> std_ppcmds val ismt : std_ppcmds -> bool @@ -30,12 +29,6 @@ val app : std_ppcmds -> std_ppcmds -> std_ppcmds val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds (** Infix alias for [app]. *) -val eval_ppcmds : std_ppcmds -> std_ppcmds -(** Force computation. *) - -val is_empty : std_ppcmds -> bool -(** Test emptyness. *) - (** {6 Derived commands} *) val spc : unit -> std_ppcmds @@ -73,10 +66,6 @@ val tag : pp_tag -> std_ppcmds -> std_ppcmds val open_tag : pp_tag -> std_ppcmds val close_tag : unit -> std_ppcmds -(** {6 Utilities} *) - -val string_of_ppcmds : std_ppcmds -> string - (** {6 Printing combinators} *) val pr_comma : unit -> std_ppcmds @@ -145,13 +134,11 @@ val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds val pr_loc : Loc.t -> std_ppcmds -(** {6 Low-level pretty-printing functions with and without flush} *) +(** {6 Main renderers, to formatter and to string } *) (** FIXME: These ignore the logging settings and call [Format] directly *) type tag_handler = pp_tag -> Format.tag -(** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and flush [fmt] *) -val msg_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit - -(** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) -val pp_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit +(** [msg_with fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) +val pp_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit +val string_of_ppcmds : ?pp_tag:tag_handler -> std_ppcmds -> string diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index d89bf95ee..d8e382155 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -66,7 +66,7 @@ let pp_header_comment = function | None -> mt () | Some com -> pp_comment com ++ fnl2 () -let then_nl pp = if Pp.is_empty pp then mt () else pp ++ fnl () +let then_nl pp = if Pp.ismt pp then mt () else pp ++ fnl () let pp_tdummy usf = if usf.tdummy || usf.tunknown then str "type __ = Obj.t" ++ fnl () else mt () @@ -618,7 +618,7 @@ and pp_module_type params = function push_visible mp params; let try_pp_specif l x = let px = pp_specif x in - if Pp.is_empty px then l else px::l + if Pp.ismt px then l else px::l in (* We cannot use fold_right here due to side effects in pp_specif *) let l = List.fold_left try_pp_specif [] sign in @@ -696,7 +696,7 @@ and pp_module_expr params = function push_visible mp params; let try_pp_structure_elem l x = let px = pp_structure_elem x in - if Pp.is_empty px then l else px::l + if Pp.ismt px then l else px::l in (* We cannot use fold_right here due to side effects in pp_structure_elem *) let l = List.fold_left try_pp_structure_elem [] sel in @@ -714,7 +714,7 @@ let rec prlist_sep_nonempty sep f = function | h::t -> let e = f h in let r = prlist_sep_nonempty sep f t in - if Pp.is_empty e then r + if Pp.ismt e then r else e ++ sep () ++ r let do_struct f s = diff --git a/printing/printer.ml b/printing/printer.ml index 00c2b636b..5e7e9ce54 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -722,7 +722,7 @@ let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () = let end_cmd = str "This subproof is complete, but there are some unfocused goals." ++ (let s = Proof_global.Bullet.suggest p in - if Pp.is_empty s then s else fnl () ++ s) ++ + if Pp.ismt s then s else fnl () ++ s) ++ fnl () in pr_subgoals ~pr_first:false (Some end_cmd) bsigma seeds shelf [] bgoals diff --git a/printing/printmod.ml b/printing/printmod.ml index ac7ff7697..521b4ec2a 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -405,11 +405,11 @@ let rec printable_body dir = let print_expression' is_type env mp me = States.with_state_protection - (fun e -> eval_ppcmds (print_expression is_type env mp [] e)) me + (fun e -> print_expression is_type env mp [] e) me let print_signature' is_type env mp me = States.with_state_protection - (fun e -> eval_ppcmds (print_signature is_type env mp [] e)) me + (fun e -> print_signature is_type env mp [] e) me let unsafe_print_module env mp with_body mb = let name = print_modpath [] mp in diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 5521e8a40..2cb608326 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -13,7 +13,9 @@ open Flags open Vernac open Pcoq -let top_stderr x = msg_with ~pp_tag:Ppstyle.to_format !Pp_control.err_ft x +let top_stderr x = + pp_with ~pp_tag:Ppstyle.to_format !Pp_control.err_ft x; + Format.pp_print_flush !Pp_control.err_ft () (* A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index cc1c44fe3..0ece0b014 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -595,7 +595,7 @@ let parse_args arglist = parse () with | UserError(_, s) as e -> - if is_empty s then exit 1 + if ismt s then exit 1 else fatal_error (CErrors.print e) false | any -> fatal_error (CErrors.print any) (CErrors.is_anomaly any) diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index de7bc6929..5d17054fc 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -143,7 +143,8 @@ let pr_new_syntax_in_context loc chan_beautify ocom = | None -> mt() in let after = comment (CLexer.extract_comments (snd loc)) in if !beautify_file then - Pp.msg_with !Pp_control.std_ft (hov 0 (before ++ com ++ after)) + (Pp.pp_with !Pp_control.std_ft (hov 0 (before ++ com ++ after)); + Format.pp_print_flush !Pp_control.std_ft ()) else Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); States.unfreeze fs; diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 148d029bc..5b91af03c 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -91,7 +91,7 @@ let process_vernac_interp_error with_header exn = match fst exn with let s = Lazy.force s in wrap_vernac_error with_header exn (str "Tactic failure" ++ - (if Pp.is_empty s then s else str ": " ++ s) ++ + (if Pp.ismt s then s else str ": " ++ s) ++ if Int.equal i 0 then str "." else str " (level " ++ int i ++ str").") | AlreadyDeclared msg -> wrap_vernac_error with_header exn (msg ++ str ".") -- cgit v1.2.3 From fd6271089a0f0fcaa6d89e347d76247c7c831d23 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Fri, 30 Sep 2016 19:44:13 +0200 Subject: [pp] Force well-formed boxes by construction. We replace open/close box commands in favor of the create box ones. --- lib/pp.ml | 14 ++------------ lib/pp.mli | 15 +++------------ plugins/rtauto/proof_search.ml | 6 +++--- 3 files changed, 8 insertions(+), 27 deletions(-) (limited to 'plugins') diff --git a/lib/pp.ml b/lib/pp.ml index 4ff10b4d7..388eed9e4 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -32,13 +32,12 @@ type std_ppcmds = | Ppcmd_string of string | Ppcmd_glue of std_ppcmds list | Ppcmd_box of block_type * std_ppcmds + | Ppcmd_tag of pp_tag * std_ppcmds + (* Are those redundant? *) | Ppcmd_print_break of int * int | Ppcmd_white_space of int | Ppcmd_force_newline - | Ppcmd_open_box of block_type - | Ppcmd_close_box | Ppcmd_comment of string list - | Ppcmd_tag of pp_tag * std_ppcmds (* Compute length of an UTF-8 encoded string Rem 1 : utf8_length <= String.length (equal if pure ascii) @@ -137,13 +136,6 @@ let v n s = Ppcmd_box(Pp_vbox n,s) let hv n s = Ppcmd_box(Pp_hvbox n,s) let hov n s = Ppcmd_box(Pp_hovbox n,s) -(* Opening and closing of boxes *) -let hb n = Ppcmd_open_box(Pp_hbox n) -let vb n = Ppcmd_open_box(Pp_vbox n) -let hvb n = Ppcmd_open_box(Pp_hvbox n) -let hovb n = Ppcmd_open_box(Pp_hovbox n) -let close () = Ppcmd_close_box - (* Opening and closed of tags *) let tag t s = Ppcmd_tag(t,s) @@ -191,8 +183,6 @@ let pp_with ?pp_tag ft = cpp_open_box bty ; if not (Format.over_max_boxes ()) then pp_cmd ss; Format.pp_close_box ft () - | Ppcmd_open_box bty -> cpp_open_box bty - | Ppcmd_close_box -> pp_close_box ft () | Ppcmd_white_space n -> pp_print_break ft n 0 | Ppcmd_print_break(m,n) -> pp_print_break ft m n | Ppcmd_force_newline -> pp_force_newline ft () diff --git a/lib/pp.mli b/lib/pp.mli index ed97226ae..cee7fa052 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -22,13 +22,12 @@ type std_ppcmds = | Ppcmd_string of string | Ppcmd_glue of std_ppcmds list | Ppcmd_box of block_type * std_ppcmds + | Ppcmd_tag of pp_tag * std_ppcmds + (* Are those redundant? *) | Ppcmd_print_break of int * int | Ppcmd_white_space of int | Ppcmd_force_newline - | Ppcmd_open_box of block_type - | Ppcmd_close_box | Ppcmd_comment of string list - | Ppcmd_tag of pp_tag * std_ppcmds (** {6 Formatting commands} *) @@ -69,15 +68,7 @@ val v : int -> std_ppcmds -> std_ppcmds val hv : int -> std_ppcmds -> std_ppcmds val hov : int -> std_ppcmds -> std_ppcmds -(** {6 Opening and closing of boxes} *) - -val hb : int -> std_ppcmds -val vb : int -> std_ppcmds -val hvb : int -> std_ppcmds -val hovb : int -> std_ppcmds -val close : unit -> std_ppcmds - -(** {6 Opening and closing of tags} *) +(** {6 Tagging} *) val tag : pp_tag -> std_ppcmds -> std_ppcmds diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 8b9261113..1ad4d622b 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -505,12 +505,12 @@ let pp_mapint map = pp_form obj ++ str " => " ++ pp_list (fun (i,f) -> pp_form f) l ++ cut ()) ) map; - str "{ " ++ vb 0 ++ (!pp) ++ str " }" ++ close () + str "{ " ++ hv 0 (!pp ++ str " }") let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2 let pp_gl gl= cut () ++ - str "{ " ++ vb 0 ++ + str "{ " ++ hv 0 ( begin match gl.abs with None -> str "" @@ -520,7 +520,7 @@ let pp_gl gl= cut () ++ str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++ str "arrows=" ++ pp_mapint gl.right ++ cut () ++ str "cnx =" ++ pp_list pp_connect gl.cnx ++ cut () ++ - str "goal =" ++ pp_form gl.gl ++ str " }" ++ close () + str "goal =" ++ pp_form gl.gl ++ str " }") let pp = function -- cgit v1.2.3 From 5b8bfee9d80e550cd81e326ec134430b2a4797a5 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 29 Sep 2016 16:30:21 +0200 Subject: [pp] Make feedback the only logging mechanism. Previously to this patch, Coq featured to distinct logging paths: the console legacy one, based on `Pp.std_ppcmds` and Ocaml's `Format` module, and the `Feedback` one, intended to encapsulate message inside a more general, GUI-based feedback protocol. This patch removes the legacy logging path and makes feedback canonical. Thus, the core of Coq has no dependency on console code anymore. Additionally, this patch resolves the duplication of "document" formats present in the same situation. The original console-based printing code relied on an opaque datatype `std_ppcmds`, (mostly a reification of `Format`'s format strings) that could be then rendered to the console. However, the feedback path couldn't reuse this type due to its opaque nature. The first versions just embedded rending of `std_ppcmds` to a string, however in 8.5 a new "rich printing" type, `Richpp.richpp` was introduced. The idea for this type was to be serializable, however it brought several problems: it didn't have proper document manipulation operations, its format was overly verbose and didn't preserve the full layout, and it still relied on `Format` for generation, making client-side rendering difficult. We thus follow the plan outlined in CEP#9, that is to say, we take a public and refactored version of `std_ppcmds` as the canonical "document type", and move feedback to be over there. The toplevel now is implemented as a feedback listener and has ownership of the console. `richpp` is now IDE-specific, and only used for legacy rendering. It could go away in future versions. `std_ppcmds` carries strictly more information and is friendlier to client-side rendering and display control. Thus, the new panorama is: - `Feedback` has become a very module for event dispatching. - `Pp` contains a target-independent box-based document format. It also contains the `Format`-based renderer. - All console access lives in `toplevel`, with console handlers private to coqtop. _NOTE_: After this patch, many printing parameters such as printing width or depth should be set client-side. This works better IMO, clients don't need to notify Coq about resizing anywmore. Indeed, for box-based capable backends such as HTML or LaTeX, the UI can directly render and let the engine perform the word breaking work. _NOTE_: Many messages could benefit from new features of the output format, however we have chosen not to alter them to preserve output. A Future commits will move console tag handling in `Pp_style` to `toplevel/`, where it logically belongs. The only change with regards to printing is that the "Error:" header was added to console output in several different positions, we have removed some of this duplication, now error messages should be a bit more consistent. --- Makefile.build | 7 +- dev/doc/changes.txt | 52 +++++++ dev/top_printers.ml | 2 +- ide/coq.ml | 2 +- ide/coqOps.ml | 44 +++--- ide/coqide.ml | 16 +- ide/coqidetop.mllib | 2 +- ide/ide.mllib | 4 +- ide/ide_slave.ml | 20 +-- ide/ideutils.ml | 4 +- ide/ideutils.mli | 2 +- ide/interface.mli | 9 +- ide/richpp.ml | 200 +++++++++++++++++++++++++ ide/richpp.mli | 64 ++++++++ ide/wg_Command.ml | 2 +- ide/wg_MessageView.ml | 21 +-- ide/wg_MessageView.mli | 4 +- ide/wg_ProofView.ml | 12 +- ide/xmlprotocol.ml | 71 +++++++-- ide/xmlprotocol.mli | 3 +- lib/cErrors.ml | 14 +- lib/clib.mllib | 4 +- lib/feedback.ml | 177 ++-------------------- lib/feedback.mli | 33 +---- lib/pp.ml | 9 +- lib/pp.mli | 24 +++ lib/pp_control.ml | 93 ------------ lib/pp_control.mli | 38 ----- lib/richpp.ml | 200 ------------------------- lib/richpp.mli | 64 -------- plugins/extraction/extract_env.ml | 5 +- stm/asyncTaskQueue.ml | 12 +- stm/stm.ml | 10 +- test-suite/output/Arguments.out | 4 +- test-suite/output/Arguments_renaming.out | 14 +- test-suite/output/Errors.out | 2 +- test-suite/output/FunExt.out | 2 +- test-suite/output/Notations.out | 20 +-- test-suite/output/ltac.out | 5 +- test-suite/output/ltac_missing_args.out | 21 ++- tools/fake_ide.ml | 12 +- toplevel/coqloop.ml | 63 +++++--- toplevel/coqloop.mli | 2 + toplevel/coqtop.ml | 28 +++- toplevel/vernac.ml | 9 +- vernac/explainErr.ml | 42 +++--- vernac/explainErr.mli | 2 +- vernac/topfmt.ml | 245 +++++++++++++++++++++++++++++++ vernac/topfmt.mli | 49 +++++++ vernac/vernac.mllib | 1 + vernac/vernacentries.ml | 12 +- 51 files changed, 923 insertions(+), 834 deletions(-) create mode 100644 ide/richpp.ml create mode 100644 ide/richpp.mli delete mode 100644 lib/pp_control.ml delete mode 100644 lib/pp_control.mli delete mode 100644 lib/richpp.ml delete mode 100644 lib/richpp.mli create mode 100644 vernac/topfmt.ml create mode 100644 vernac/topfmt.mli (limited to 'plugins') diff --git a/Makefile.build b/Makefile.build index 9d76638e1..c62420326 100644 --- a/Makefile.build +++ b/Makefile.build @@ -440,9 +440,10 @@ $(COQWORKMGR): $(call bestobj, lib/clib.cma stm/coqworkmgrApi.cmo tools/coqworkm # fake_ide : for debugging or test-suite purpose, a fake ide simulating # a connection to coqtop -ideslave -FAKEIDECMO:= lib/clib.cma lib/cErrors.cmo lib/spawn.cmo ide/document.cmo \ - ide/serialize.cmo ide/xml_lexer.cmo ide/xml_parser.cmo ide/xml_printer.cmo \ - ide/xmlprotocol.cmo tools/fake_ide.cmo +FAKEIDECMO:= lib/clib.cma lib/cErrors.cmo lib/spawn.cmo \ + ide/document.cmo ide/serialize.cmo ide/richpp.cmo ide/xml_lexer.cmo \ + ide/xml_parser.cmo ide/xml_printer.cmo ide/xmlprotocol.cmo \ + tools/fake_ide.cmo $(FAKEIDE): $(call bestobj, $(FAKEIDECMO)) | $(IDETOPLOOPCMA:.cma=$(BESTDYN)) $(SHOW)'OCAMLBEST -o $@' diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 12c3ec454..53e9a282f 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -70,6 +70,58 @@ work for EXTEND macros though. - The header parameter to `user_err` has been made optional. +** Pretty printing ** + +Some functions have been removed, see pretty printing below for more +details. + +* Pretty Printing and XML protocol * + +The type std_cmdpps has been reworked and made the canonical "Coq rich +document type". This allows for a more uniform handling of printing +(specially in IDEs). The main consequences are: + + - Richpp has been confined to IDE use. Most of previous uses of the + `richpp` type should be replaced now by `Pp.std_cmdpps`. Main API + has been updated. + + - The XML protocol will send a new message type of `pp`, which should + be rendered client-wise. + + - `Set Printing Width` is deprecated, now width is controlled + client-side. + + - `Pp_control` has removed. The new module `Topfmt` implements + console control for the toplevel. + + - The impure tag system in Pp has been removed. This also does away + with the printer signatures and functors. Now printers tag + unconditionally. + + - The following functions have been removed from `Pp`: + + val stras : int * string -> std_ppcmds + val tbrk : int * int -> std_ppcmds + val tab : unit -> std_ppcmds + val pifb : unit -> std_ppcmds + val comment : int -> std_ppcmds + val comments : ((int * int) * string) list ref + val eval_ppcmds : std_ppcmds -> std_ppcmds + val is_empty : std_ppcmds -> bool + val t : std_ppcmds -> std_ppcmds + val hb : int -> std_ppcmds + val vb : int -> std_ppcmds + val hvb : int -> std_ppcmds + val hovb : int -> std_ppcmds + val tb : unit -> std_ppcmds + val close : unit -> std_ppcmds + val tclose : unit -> std_ppcmds + val open_tag : Tag.t -> std_ppcmds + val close_tag : unit -> std_ppcmds + val msg_with : ... + + module Tag + ========================================= = CHANGES BETWEEN COQ V8.5 AND COQ V8.6 = ========================================= diff --git a/dev/top_printers.ml b/dev/top_printers.ml index dc354b130..cd464801b 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -29,7 +29,7 @@ let _ = set_bool_option_value ["Printing";"Matching"] false let _ = Detyping.set_detype_anonymous (fun _ _ -> raise Not_found) (* std_ppcmds *) -let pp x = Pp.pp_with !Pp_control.std_ft x +let pp x = Pp.pp_with !Topfmt.std_ft x (** Future printer *) diff --git a/ide/coq.ml b/ide/coq.ml index 9637b5b3f..e2036beee 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -205,7 +205,7 @@ type handle = { proc : CoqTop.process; xml_oc : Xml_printer.t; mutable alive : bool; - mutable waiting_for : ccb option; (* last call + callback + log *) + mutable waiting_for : ccb option; (* last call + callback *) } (** Coqtop process status : diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 0f3629c8f..7982ffc8b 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -162,13 +162,16 @@ let flags_to_color f = else if List.mem `INCOMPLETE f then `NAME "gray" else `NAME Preferences.processed_color#get -let validate s = - let open Xml_datatype in - let rec validate = function - | PCData s -> Glib.Utf8.validate s - | Element (_, _, children) -> List.for_all validate children - in - validate (Richpp.repr s) +(* Move to utils? *) +let rec validate (s : Pp.std_ppcmds) = match s with + | Pp.Ppcmd_empty + | Pp.Ppcmd_print_break _ + | Pp.Ppcmd_force_newline -> true + | Pp.Ppcmd_glue l -> List.for_all validate l + | Pp.Ppcmd_string s -> Glib.Utf8.validate s + | Pp.Ppcmd_box (_,s) + | Pp.Ppcmd_tag (_,s) -> validate s + | Pp.Ppcmd_comment s -> List.for_all Glib.Utf8.validate s module Doc = Document @@ -418,9 +421,10 @@ object(self) | _ -> false method private enqueue_feedback msg = + (* Minilib.log ("Feedback received: " ^ Xml_printer.to_string_fmt (Xmlprotocol.of_feedback msg)); *) let id = msg.id in if self#is_dummy_id id then () else Queue.add msg feedbacks - + method private process_feedback () = let rec eat_feedback n = if n = 0 then true else @@ -466,7 +470,7 @@ object(self) (Printf.sprintf "%s %s %s" filepath ident ty) | Message(Error, loc, msg), Some (id,sentence) -> let loc = Option.default Loc.ghost loc in - let msg = Richpp.raw_print msg in + let msg = Pp.string_of_ppcmds msg in log "ErrorMsg" id; remove_flag sentence `PROCESSING; add_flag sentence (`ERROR (loc, msg)); @@ -476,14 +480,15 @@ object(self) self#position_error_tag_at_sentence sentence (Some (Loc.unloc loc)) | Message(Warning, loc, msg), Some (id,sentence) -> let loc = Option.default Loc.ghost loc in - let rmsg = Richpp.raw_print msg in - log "WarningMsg" id; + let rmsg = Pp.string_of_ppcmds msg in + log ("WarningMsg: " ^ Pp.string_of_ppcmds msg)id; add_flag sentence (`WARNING (loc, rmsg)); self#attach_tooltip sentence loc rmsg; self#position_warning_tag_at_sentence sentence loc; messages#push Warning msg | Message(lvl, loc, msg), Some (id,sentence) -> - messages#push lvl msg + log ("Msg: " ^ Pp.string_of_ppcmds msg) id; + messages#push lvl msg | InProgress n, _ -> if n < 0 then processed <- processed + abs n else to_process <- to_process + n @@ -629,10 +634,9 @@ object(self) if Queue.is_empty queue then conclude topstack else match Queue.pop queue, topstack with | `Skip(start,stop), [] -> - - logger Feedback.Error (Richpp.richpp_of_string "You must close the proof with Qed or Admitted"); + logger Feedback.Error (Pp.str "You must close the proof with Qed or Admitted"); self#discard_command_queue queue; - conclude [] + conclude [] | `Skip(start,stop), (_,s) :: topstack -> assert(start#equal (buffer#get_iter_at_mark s.start)); assert(stop#equal (buffer#get_iter_at_mark s.stop)); @@ -646,7 +650,7 @@ object(self) let handle_answer = function | Good (id, (Util.Inl (* NewTip *) (), msg)) -> Doc.assign_tip_id document id; - logger Feedback.Notice (Richpp.richpp_of_string msg); + logger Feedback.Notice (Pp.str msg); self#commit_queue_transaction sentence; loop id [] | Good (id, (Util.Inr (* Unfocus *) tip, msg)) -> @@ -654,7 +658,7 @@ object(self) let topstack, _ = Doc.context document in self#exit_focus; self#cleanup (Doc.cut_at document tip); - logger Feedback.Notice (Richpp.richpp_of_string msg); + logger Feedback.Notice (Pp.str msg); self#mark_as_needed sentence; if Queue.is_empty queue then loop tip [] else loop tip (List.rev topstack) @@ -673,7 +677,7 @@ object(self) let next = function | Good _ -> messages#clear; - messages#push Feedback.Info (Richpp.richpp_of_string "All proof terms checked by the kernel"); + messages#push Feedback.Info (Pp.str "All proof terms checked by the kernel"); Coq.return () | Fail x -> self#handle_failure x in Coq.bind (Coq.status true) next @@ -860,7 +864,7 @@ object(self) let next = function | Fail (_, l, str) -> (* FIXME: check *) display_error (l, str); - messages#add (Richpp.richpp_of_string ("Unsuccessfully tried: "^phrase)); + messages#add (Pp.str ("Unsuccessfully tried: "^phrase)); more | Good msg -> messages#add_string msg; @@ -906,7 +910,7 @@ object(self) let get_initial_state = let next = function | Fail (_, _, message) -> - let message = "Couldn't initialize coqtop\n\n" ^ (Richpp.raw_print message) in + let message = "Couldn't initialize coqtop\n\n" ^ (Pp.string_of_ppcmds message) in let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok ~message_type:`ERROR ~message () in ignore (popup#run ()); exit 1 | Good id -> initial_state <- id; Coq.return () in diff --git a/ide/coqide.ml b/ide/coqide.ml index 3d56f9dd4..25858acce 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -318,7 +318,7 @@ let export kind sn = local_cd f ^ cmd_coqdoc#get ^ " --" ^ kind ^ " -o " ^ (Filename.quote output) ^ " " ^ (Filename.quote basef) ^ " 2>&1" in - sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd)); + sn.messages#set (Pp.str ("Running: "^cmd)); let finally st = flash_info (cmd ^ pr_exit_status st) in run_command (fun msg -> sn.messages#add_string msg) finally cmd @@ -431,7 +431,7 @@ let compile sn = ^ " " ^ (Filename.quote f) ^ " 2>&1" in let buf = Buffer.create 1024 in - sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd)); + sn.messages#set (Pp.str ("Running: "^cmd)); let display s = sn.messages#add_string s; Buffer.add_string buf s @@ -441,8 +441,8 @@ let compile sn = flash_info (f ^ " successfully compiled") else begin flash_info (f ^ " failed to compile"); - sn.messages#set (Richpp.richpp_of_string "Compilation output:\n"); - sn.messages#add (Richpp.richpp_of_string (Buffer.contents buf)); + sn.messages#set (Pp.str "Compilation output:\n"); + sn.messages#add (Pp.str (Buffer.contents buf)); end in run_command display finally cmd @@ -464,7 +464,7 @@ let make sn = |Some f -> File.saveall (); let cmd = local_cd f ^ cmd_make#get ^ " 2>&1" in - sn.messages#set (Richpp.richpp_of_string "Compilation output:\n"); + sn.messages#set (Pp.str "Compilation output:\n"); Buffer.reset last_make_buf; last_make := ""; last_make_index := 0; @@ -508,11 +508,11 @@ let next_error sn = let stopi = b#get_iter_at_byte ~line:(line-1) stop in b#apply_tag Tags.Script.error ~start:starti ~stop:stopi; b#place_cursor ~where:starti; - sn.messages#set (Richpp.richpp_of_string error_msg); + sn.messages#set (Pp.str error_msg); sn.script#misc#grab_focus () with Not_found -> last_make_index := 0; - sn.messages#set (Richpp.richpp_of_string "No more errors.\n") + sn.messages#set (Pp.str "No more errors.\n") let next_error = cb_on_current_term next_error @@ -789,7 +789,7 @@ let coqtop_arguments sn = let args = String.concat " " args in let msg = Printf.sprintf "Invalid arguments: %s" args in let () = sn.messages#clear in - sn.messages#push Feedback.Error (Richpp.richpp_of_string msg) + sn.messages#push Feedback.Error (Pp.str msg) else dialog#destroy () in let _ = entry#connect#activate ok_cb in diff --git a/ide/coqidetop.mllib b/ide/coqidetop.mllib index ed1fa465d..043ad6008 100644 --- a/ide/coqidetop.mllib +++ b/ide/coqidetop.mllib @@ -2,7 +2,7 @@ Xml_lexer Xml_parser Xml_printer Serialize -Richprinter +Richpp Xmlprotocol Texmacspp Document diff --git a/ide/ide.mllib b/ide/ide.mllib index 72a14134b..12170c462 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -9,11 +9,11 @@ Config_lexer Utf8_convert Preferences Project_file -Serialize -Richprinter Xml_lexer Xml_parser Xml_printer +Serialize +Richpp Xmlprotocol Ideutils Coq diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 0cb8d377f..88b61042e 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -32,9 +32,6 @@ let init_signal_handler () = let f _ = if !catch_break then raise Sys.Break else Control.interrupt := true in Sys.set_signal Sys.sigint (Sys.Signal_handle f) - -(** Redirection of standard output to a printable buffer *) - let pr_with_pid s = Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s let pr_error s = pr_with_pid s @@ -174,13 +171,13 @@ let process_goal sigma g = let id = Goal.uid g in let ccl = let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in - Richpp.richpp_of_pp (pr_goal_concl_style_env env sigma norm_constr) + pr_goal_concl_style_env env sigma norm_constr in let process_hyp d (env,l) = let d = CompactedDecl.map_constr (Reductionops.nf_evar sigma) d in let d' = CompactedDecl.to_named_context d in (List.fold_right Environ.push_named d' env, - (Richpp.richpp_of_pp (pr_compacted_decl env sigma d)) :: l) in + (pr_compacted_decl env sigma d) :: l) in let (_env, hyps) = Context.Compacted.fold process_hyp (Termops.compact_named_context (Environ.named_context env)) ~init:(min_env,[]) in @@ -340,13 +337,10 @@ let handle_exn (e, info) = let loc_of e = match Loc.get_loc e with | Some loc when not (Loc.is_ghost loc) -> Some (Loc.unloc loc) | _ -> None in - let mk_msg () = - let msg = CErrors.print ~info e in - Richpp.richpp_of_pp msg - in + let mk_msg () = CErrors.print ~info e in match e with - | CErrors.Drop -> dummy, None, Richpp.richpp_of_string "Drop is not allowed by coqide!" - | CErrors.Quit -> dummy, None, Richpp.richpp_of_string "Quit is not allowed by coqide!" + | CErrors.Drop -> dummy, None, Pp.str "Drop is not allowed by coqide!" + | CErrors.Quit -> dummy, None, Pp.str "Quit is not allowed by coqide!" | e -> match Stateid.get info with | Some (valid, _) -> valid, loc_of info, mk_msg () @@ -446,7 +440,6 @@ let print_xml = try Xml_printer.print oc xml; Mutex.unlock m with e -> let e = CErrors.push e in Mutex.unlock m; iraise e - let slave_feeder xml_oc msg = let xml = Xmlprotocol.of_feedback msg in print_xml xml_oc xml @@ -467,7 +460,6 @@ let loop () = (* SEXP parser make *) let xml_ic = Xml_parser.make (Xml_parser.SLexbuf in_lb) in let () = Xml_parser.check_eof xml_ic false in - Feedback.set_logger Feedback.feedback_logger; Feedback.add_feeder (slave_feeder xml_oc); (* We'll handle goal fetching and display in our own way *) Vernacentries.enable_goal_printing := false; @@ -478,7 +470,7 @@ let loop () = (* pr_with_pid (Xml_printer.to_string_fmt xml_query); *) let Xmlprotocol.Unknown q = Xmlprotocol.to_call xml_query in let () = pr_debug_call q in - let r = eval_call q in + let r = eval_call q in let () = pr_debug_answer q r in (* pr_with_pid (Xml_printer.to_string_fmt (Xmlprotocol.of_answer q r)); *) print_xml xml_oc (Xmlprotocol.of_answer q r); diff --git a/ide/ideutils.ml b/ide/ideutils.ml index c3a280796..498a911ee 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -327,7 +327,7 @@ let textview_width (view : #GText.view_skel) = let char_width = GPango.to_pixels metrics#approx_char_width in pixel_width / char_width -type logger = Feedback.level -> Richpp.richpp -> unit +type logger = Feedback.level -> Pp.std_ppcmds -> unit let default_logger level message = let level = match level with @@ -337,7 +337,7 @@ let default_logger level message = | Feedback.Warning -> `WARNING | Feedback.Error -> `ERROR in - Minilib.log ~level (xml_to_string message) + Minilib.log ~level (Pp.string_of_ppcmds message) (** {6 File operations} *) diff --git a/ide/ideutils.mli b/ide/ideutils.mli index e32a4d9e3..1ae66e23e 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -69,7 +69,7 @@ val requote : string -> string val textview_width : #GText.view_skel -> int (** Returns an approximate value of the character width of a textview *) -type logger = Feedback.level -> Richpp.richpp -> unit +type logger = Feedback.level -> Pp.std_ppcmds -> unit val default_logger : logger (** Default logger. It logs messages that the casual user should not see. *) diff --git a/ide/interface.mli b/ide/interface.mli index 123cac6c2..43446f391 100644 --- a/ide/interface.mli +++ b/ide/interface.mli @@ -12,15 +12,14 @@ type raw = bool type verbose = bool -type richpp = Richpp.richpp (** The type of coqtop goals *) type goal = { goal_id : string; (** Unique goal identifier *) - goal_hyp : richpp list; + goal_hyp : Pp.std_ppcmds list; (** List of hypotheses *) - goal_ccl : richpp; + goal_ccl : Pp.std_ppcmds; (** Goal conclusion *) } @@ -119,7 +118,7 @@ type edit_id = Feedback.edit_id should probably retract to that point *) type 'a value = | Good of 'a - | Fail of (state_id * location * richpp) + | Fail of (state_id * location * Pp.std_ppcmds) type ('a, 'b) union = ('a, 'b) Util.union @@ -203,7 +202,7 @@ type about_sty = unit type about_rty = coq_info type handle_exn_sty = Exninfo.iexn -type handle_exn_rty = state_id * location * richpp +type handle_exn_rty = state_id * location * Pp.std_ppcmds (* Retrocompatibility stuff *) type interp_sty = (raw * verbose) * string diff --git a/ide/richpp.ml b/ide/richpp.ml new file mode 100644 index 000000000..c0128dbc2 --- /dev/null +++ b/ide/richpp.ml @@ -0,0 +1,200 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* assert false + | Node (node, child, pos, ctx) -> + let data = Buffer.contents pp_buffer in + let () = Buffer.clear pp_buffer in + let () = context.stack <- Node (node, PCData data :: child, pos, ctx) in + context.offset <- context.offset + len + in + + let open_xml_tag tag = + let () = push_pcdata () in + context.stack <- Node (tag, [], context.offset, context.stack) + in + + let close_xml_tag tag = + let () = push_pcdata () in + match context.stack with + | Leaf -> assert false + | Node (node, child, pos, ctx) -> + let () = assert (String.equal tag node) in + let annotation = + try Int.Map.find (int_of_string node) context.annotations + with _ -> None + in + let annotation = { + annotation = annotation; + startpos = pos; + endpos = context.offset; + } in + let xml = Element (node, annotation, List.rev child) in + match ctx with + | Leaf -> + (** Final node: we keep the result in a dummy context *) + context.stack <- Node ("", [xml], 0, Leaf) + | Node (node, child, pos, ctx) -> + context.stack <- Node (node, xml :: child, pos, ctx) + in + + let open Format in + + let ft = formatter_of_buffer pp_buffer in + + let tag_functions = { + mark_open_tag = (fun tag -> let () = open_xml_tag tag in ""); + mark_close_tag = (fun tag -> let () = close_xml_tag tag in ""); + print_open_tag = ignore; + print_close_tag = ignore; + } in + + pp_set_formatter_tag_functions ft tag_functions; + pp_set_mark_tags ft true; + + (* Set formatter width. This is currently a hack and duplicate code + with Pp_control. Hopefully it will be fixed better in Coq 8.7 *) + let w = pp_get_margin str_formatter () in + let m = max (64 * w / 100) (w-30) in + pp_set_margin ft w; + pp_set_max_indent ft m; + + (** The whole output must be a valid document. To that + end, we nest the document inside tags. *) + pp_open_tag ft "pp"; + Pp.(pp_with ~pp_tag ft ppcmds); + pp_close_tag ft (); + + (** Get the resulting XML tree. *) + let () = pp_print_flush ft () in + let () = assert (Buffer.length pp_buffer = 0) in + match context.stack with + | Node ("", [xml], 0, Leaf) -> xml + | _ -> assert false + + +let annotations_positions xml = + let rec node accu = function + | Element (_, { annotation = Some annotation; startpos; endpos }, cs) -> + children ((annotation, (startpos, endpos)) :: accu) cs + | Element (_, _, cs) -> + children accu cs + | _ -> + accu + and children accu cs = + List.fold_left node accu cs + in + node [] xml + +let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml = + let rec node = function + | Element (index, { annotation; startpos; endpos }, cs) -> + let attributes = + [ "startpos", string_of_int startpos; + "endpos", string_of_int endpos + ] + @ (match annotation with + | None -> [] + | Some annotation -> attributes_of_annotation annotation + ) + in + let tag = + match annotation with + | None -> index + | Some annotation -> tag_of_annotation annotation + in + Element (tag, attributes, List.map node cs) + | PCData s -> + PCData s + in + node xml + +type richpp = xml + +let repr xml = xml +let richpp_of_xml xml = xml +let richpp_of_string s = PCData s + +let richpp_of_pp pp = + let annotate t = Some (Ppstyle.repr t) in + let rec drop = function + | PCData s -> [PCData s] + | Element (_, annotation, cs) -> + let cs = List.concat (List.map drop cs) in + match annotation.annotation with + | None -> cs + | Some s -> [Element (String.concat "." s, [], cs)] + in + let xml = rich_pp annotate pp in + Element ("_", [], drop xml) + +let raw_print xml = + let buf = Buffer.create 1024 in + let rec print = function + | PCData s -> Buffer.add_string buf s + | Element (_, _, cs) -> List.iter print cs + in + let () = print xml in + Buffer.contents buf + diff --git a/ide/richpp.mli b/ide/richpp.mli new file mode 100644 index 000000000..2e839e996 --- /dev/null +++ b/ide/richpp.mli @@ -0,0 +1,64 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'annotation option) -> Pp.std_ppcmds -> + 'annotation located Xml_datatype.gxml + +(** [annotations_positions ssdoc] returns a list associating each + annotations with its position in the string from which [ssdoc] is + built. *) +val annotations_positions : + 'annotation located Xml_datatype.gxml -> + ('annotation * (int * int)) list + +(** [xml_of_rich_pp ssdoc] returns an XML representation of the + semi-structured document [ssdoc]. *) +val xml_of_rich_pp : + ('annotation -> string) -> + ('annotation -> (string * string) list) -> + 'annotation located Xml_datatype.gxml -> + Xml_datatype.xml + +(** {5 Enriched text} *) + +type richpp +(** Type of text with style annotations *) + +val richpp_of_pp : Pp.std_ppcmds -> richpp +(** Extract style information from formatted text *) + +val richpp_of_xml : Xml_datatype.xml -> richpp +(** Do not use outside of dedicated areas *) + +val richpp_of_string : string -> richpp +(** Make a styled text out of a normal string *) + +val repr : richpp -> Xml_datatype.xml +(** Observe the styled text as XML *) + +(** {5 Debug/Compat} *) + +(** Represent the semi-structured document as a string, dropping any additional + information. *) +val raw_print : richpp -> string diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml index d33c0add4..b83bd107e 100644 --- a/ide/wg_Command.ml +++ b/ide/wg_Command.ml @@ -103,7 +103,7 @@ object(self) let process = Coq.bind (Coq.query (phrase,Stateid.dummy)) (function | Interface.Fail (_,l,str) -> - Ideutils.insert_xml result#buffer str; + Ideutils.insert_xml result#buffer (Richpp.richpp_of_pp str); notebook#set_page ~tab_label:(new_tab_lbl "Error") frame#coerce; Coq.return () | Interface.Good res -> diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index 0330b8eff..1cf389c75 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -28,9 +28,9 @@ class type message_view = inherit GObj.widget method connect : message_view_signals method clear : unit - method add : Richpp.richpp -> unit + method add : Pp.std_ppcmds -> unit method add_string : string -> unit - method set : Richpp.richpp -> unit + method set : Pp.std_ppcmds -> unit method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) method buffer : GText.buffer @@ -79,21 +79,14 @@ let message_view () : message_view = | Feedback.Warning -> [Tags.Message.warning] | _ -> [] in - let rec non_empty = function - | Xml_datatype.PCData "" -> false - | Xml_datatype.PCData _ -> true - | Xml_datatype.Element (_, _, children) -> List.exists non_empty children - in - if non_empty (Richpp.repr msg) then begin - let mark = `MARK mark in - Ideutils.insert_xml ~mark buffer ~tags msg; - buffer#insert ~iter:(buffer#get_iter_at_mark mark) "\n"; - push#call (level, msg) - end + let mark = `MARK mark in + Ideutils.insert_xml ~mark buffer ~tags (Richpp.richpp_of_pp msg); + buffer#insert ~iter:(buffer#get_iter_at_mark mark) "\n"; + push#call (level, msg) method add msg = self#push Feedback.Notice msg - method add_string s = self#add (Richpp.richpp_of_string s) + method add_string s = self#add (Pp.str s) method set msg = self#clear; self#add msg diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli index 2d34533de..a71d345a5 100644 --- a/ide/wg_MessageView.mli +++ b/ide/wg_MessageView.mli @@ -18,9 +18,9 @@ class type message_view = inherit GObj.widget method connect : message_view_signals method clear : unit - method add : Richpp.richpp -> unit + method add : Pp.std_ppcmds -> unit method add_string : string -> unit - method set : Richpp.richpp -> unit + method set : Pp.std_ppcmds -> unit method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) method buffer : GText.buffer diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 47c86045a..72aa9051a 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -84,7 +84,7 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with let () = hook_tag_cb tag hint sel_cb on_hover in [tag], hints in - let () = insert_xml ~tags proof#buffer hyp in + let () = insert_xml ~tags proof#buffer (Richpp.richpp_of_pp hyp) in proof#buffer#insert "\n"; insert_hyp rem_hints hs in @@ -98,13 +98,13 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with else [] in proof#buffer#insert (goal_str 1 goals_cnt); - insert_xml proof#buffer cur_goal; + insert_xml proof#buffer (Richpp.richpp_of_pp cur_goal); proof#buffer#insert "\n" in (* Insert remaining goals (no hypotheses) *) let fold_goal i _ { Interface.goal_ccl = g } = proof#buffer#insert (goal_str i goals_cnt); - insert_xml proof#buffer g; + insert_xml proof#buffer (Richpp.richpp_of_pp g); proof#buffer#insert "\n" in let () = Util.List.fold_left_i fold_goal 2 () rem_goals in @@ -144,7 +144,7 @@ let display mode (view : #GText.view_skel) goals hints evars = (* The proof is finished, with the exception of given up goals. *) view#buffer#insert "No more subgoals, but there are some goals you gave up:\n\n"; let iter goal = - insert_xml view#buffer goal.Interface.goal_ccl; + insert_xml view#buffer (Richpp.richpp_of_pp goal.Interface.goal_ccl); view#buffer#insert "\n" in List.iter iter given_up_goals; @@ -153,7 +153,7 @@ let display mode (view : #GText.view_skel) goals hints evars = (* All the goals have been resolved but those on the shelf. *) view#buffer#insert "All the remaining goals are on the shelf:\n\n"; let iter goal = - insert_xml view#buffer goal.Interface.goal_ccl; + insert_xml view#buffer (Richpp.richpp_of_pp goal.Interface.goal_ccl); view#buffer#insert "\n" in List.iter iter shelved_goals @@ -166,7 +166,7 @@ let display mode (view : #GText.view_skel) goals hints evars = view#buffer#insert "This subproof is complete, but there are some unfocused goals:\n\n"; let iter i goal = let () = view#buffer#insert (goal_str (succ i)) in - insert_xml view#buffer goal.Interface.goal_ccl; + insert_xml view#buffer (Richpp.richpp_of_pp goal.Interface.goal_ccl); view#buffer#insert "\n" in List.iteri iter bg diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index 65f44fdd3..08f23d3d4 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -97,6 +97,49 @@ let to_richpp xml = match xml with | Element ("richpp", [], [x]) -> Richpp.richpp_of_xml x | x -> raise Serialize.(Marshal_error("richpp",x)) +let of_box (ppb : Pp.block_type) = let open Pp in match ppb with + | Pp_hbox i -> constructor "ppbox" "hbox" [of_int i] + | Pp_vbox i -> constructor "ppbox" "vbox" [of_int i] + | Pp_hvbox i -> constructor "ppbox" "hvbox" [of_int i] + | Pp_hovbox i -> constructor "ppbox" "hovbox" [of_int i] + +let to_box = let open Pp in + do_match "ppbox" (fun s args -> match s with + | "hbox" -> Pp_hbox (to_int (singleton args)) + | "vbox" -> Pp_vbox (to_int (singleton args)) + | "hvbox" -> Pp_hvbox (to_int (singleton args)) + | "hovbox" -> Pp_hovbox (to_int (singleton args)) + | x -> raise (Marshal_error("*ppbox",PCData x)) + ) + +let rec of_pp (pp : Pp.std_ppcmds) = let open Pp in match pp with + | Ppcmd_empty -> constructor "ppdoc" "emtpy" [] + | Ppcmd_string s -> constructor "ppdoc" "string" [of_string s] + | Ppcmd_glue sl -> constructor "ppdoc" "glue" [of_list of_pp sl] + | Ppcmd_box (bt,s) -> constructor "ppdoc" "box" [of_pair of_box of_pp (bt,s)] + | Ppcmd_tag (t,s) -> constructor "ppdoc" "tag" [of_pair (of_list of_string) of_pp (t,s)] + | Ppcmd_print_break (i,j) + -> constructor "ppdoc" "break" [of_pair of_int of_int (i,j)] + | Ppcmd_force_newline -> constructor "ppdoc" "newline" [] + | Ppcmd_comment cmd -> constructor "ppdoc" "comment" [of_list of_string cmd] + + +let rec to_pp xpp = let open Pp in + do_match "ppdoc" (fun s args -> match s with + | "empty" -> Ppcmd_empty + | "string" -> Ppcmd_string (to_string (singleton args)) + | "glue" -> Ppcmd_glue (to_list to_pp (singleton args)) + | "box" -> let (bt,s) = to_pair to_box to_pp (singleton args) in + Ppcmd_box(bt,s) + | "tag" -> let (tg,s) = to_pair (to_list to_string) to_pp (singleton args) in + Ppcmd_tag(tg,s) + | "break" -> let (i,j) = to_pair to_int to_int (singleton args) in + Ppcmd_print_break(i, j) + | "newline" -> Ppcmd_force_newline + | "comment" -> Ppcmd_comment (to_list to_string (singleton args)) + | x -> raise (Marshal_error("*ppdoc",PCData x)) + ) xpp + let of_value f = function | Good x -> Element ("value", ["val", "good"], [f x]) | Fail (id,loc, msg) -> @@ -104,7 +147,7 @@ let of_value f = function | None -> [] | Some (s, e) -> [("loc_s", string_of_int s); ("loc_e", string_of_int e)] in let id = of_stateid id in - Element ("value", ["val", "fail"] @ loc, [id; of_richpp msg]) + Element ("value", ["val", "fail"] @ loc, [id; of_pp msg]) let to_value f = function | Element ("value", attrs, l) -> @@ -120,7 +163,7 @@ let to_value f = function in let (id, msg) = match l with [id; msg] -> (id, msg) | _ -> raise (Marshal_error("val",PCData "no id attribute")) in let id = to_stateid id in - let msg = to_richpp msg in + let msg = to_pp msg in Fail (id, loc, msg) else raise (Marshal_error("good or fail",PCData ans)) | x -> raise (Marshal_error("value",x)) @@ -147,15 +190,15 @@ let to_evar = function | x -> raise (Marshal_error("evar",x)) let of_goal g = - let hyp = of_list of_richpp g.goal_hyp in - let ccl = of_richpp g.goal_ccl in + let hyp = of_list of_pp g.goal_hyp in + let ccl = of_pp g.goal_ccl in let id = of_string g.goal_id in Element ("goal", [], [id; hyp; ccl]) let to_goal = function | Element ("goal", [], [id; hyp; ccl]) -> - let hyp = to_list to_richpp hyp in - let ccl = to_richpp ccl in - let id = to_string id in + let hyp = to_list to_pp hyp in + let ccl = to_pp ccl in + let id = to_string id in { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; } | x -> raise (Marshal_error("goal",x)) @@ -344,8 +387,8 @@ end = struct Printf.sprintf "Still focussed: [%a]." pr_focus g.bg_goals else let pr_goal { goal_hyp = hyps; goal_ccl = goal } = - "[" ^ String.concat "; " (List.map Richpp.raw_print hyps) ^ " |- " ^ - Richpp.raw_print goal ^ "]" in + "[" ^ String.concat "; " (List.map Pp.string_of_ppcmds hyps) ^ " |- " ^ + Pp.string_of_ppcmds goal ^ "]" in String.concat " " (List.map pr_goal g.fg_goals) let pr_evar (e : evar) = "[" ^ e.evar_info ^ "]" let pr_status (s : status) = @@ -701,10 +744,10 @@ let to_call : xml -> unknown_call = let pr_value_gen pr = function | Good v -> "GOOD " ^ pr v - | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^Richpp.raw_print str^"]" + | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^ Pp.string_of_ppcmds str ^ "]" | Fail (id,Some(i,j),str) -> "FAIL "^Stateid.to_string id^ - " ("^string_of_int i^","^string_of_int j^")["^Richpp.raw_print str^"]" + " ("^string_of_int i^","^string_of_int j^")["^Pp.string_of_ppcmds str^"]" let pr_value v = pr_value_gen (fun _ -> "FIXME") v let pr_full_value : type a. a call -> a value -> string = fun call value -> match call with | Add _ -> pr_value_gen (print add_rty_t ) value @@ -760,7 +803,7 @@ let document to_string_fmt = (to_string_fmt (of_value (fun _ -> PCData "b") (Good ()))); Printf.printf "or:\n\n%s\n\nwhere the attributes loc_s and loc_c are optional.\n" (to_string_fmt (of_value (fun _ -> PCData "b") - (Fail (Stateid.initial,Some (15,34),Richpp.richpp_of_string "error message")))); + (Fail (Stateid.initial,Some (15,34), Pp.str "error message")))); document_type_encoding to_string_fmt (* Moved from feedback.mli : This is IDE specific and we don't want to @@ -787,12 +830,12 @@ let to_message_level = let of_message lvl loc msg = let lvl = of_message_level lvl in let xloc = of_option of_loc loc in - let content = of_richpp msg in + let content = of_pp msg in Xml_datatype.Element ("message", [], [lvl; xloc; content]) let to_message xml = match xml with | Xml_datatype.Element ("message", [], [lvl; xloc; content]) -> - Message(to_message_level lvl, to_option to_loc xloc, to_richpp content) + Message(to_message_level lvl, to_option to_loc xloc, to_pp content) | x -> raise (Marshal_error("message",x)) let to_feedback_content = do_match "feedback_content" (fun s a -> match s,a with diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli index ca911178f..f6fae24d7 100644 --- a/ide/xmlprotocol.mli +++ b/ide/xmlprotocol.mli @@ -66,5 +66,6 @@ val of_feedback : Feedback.feedback -> xml val to_feedback : xml -> Feedback.feedback val is_feedback : xml -> bool -val of_message : Feedback.level -> Loc.t option -> Richpp.richpp -> xml +val of_message : Feedback.level -> Loc.t option -> Pp.std_ppcmds -> xml +(* val to_message : xml -> Feedback.message *) diff --git a/lib/cErrors.ml b/lib/cErrors.ml index a05964039..99b763602 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -16,16 +16,6 @@ let push = Backtrace.add_backtrace exception Anomaly of string option * std_ppcmds (* System errors *) -(* XXX: To move to common tagging functions in Pp, blocked on tag - * system cleanup as we cannot define generic error tags now. - * - * Anyways, tagging should not happen here, but in the specific - * listener to the msg_* stuff. - *) -let tag_err_str s = tag Ppstyle.error_tag (str s) ++ spc () -let err_str = tag_err_str "Error:" -let ann_str = tag_err_str "Anomaly:" - let _ = let pr = function | Anomaly (s, pp) -> Some ("\"Anomaly: " ^ string_of_ppcmds pp ^ "\"") @@ -102,7 +92,7 @@ let print_backtrace e = match Backtrace.get_backtrace e with let print_anomaly askreport e = if askreport then - hov 0 (ann_str ++ raw_anomaly e ++ spc () ++ + hov 0 (raw_anomaly e ++ spc () ++ strbrk "Please report at " ++ str Coq_config.wwwbugtracker ++ str ".") else @@ -124,7 +114,7 @@ let iprint_no_report (e, info) = let _ = register_handler begin function | UserError(s, pps) -> - hov 0 (err_str ++ where s ++ pps) + hov 0 (where s ++ pps) | _ -> raise Unhandled end diff --git a/lib/clib.mllib b/lib/clib.mllib index 1e33173ee..5a5f6afd3 100644 --- a/lib/clib.mllib +++ b/lib/clib.mllib @@ -15,7 +15,6 @@ Store Exninfo Backtrace IStream -Pp_control Flags Control Loc @@ -28,9 +27,8 @@ CStack Util Stateid Pp -Ppstyle -Richpp Feedback +Ppstyle CUnix Envars Aux_file diff --git a/lib/feedback.ml b/lib/feedback.ml index 852eec2f2..31677ecfc 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -35,7 +35,7 @@ type feedback_content = (* Extra metadata *) | Custom of Loc.t * string * xml (* Generic messages *) - | Message of level * Loc.t option * Richpp.richpp + | Message of level * Loc.t option * Pp.std_ppcmds type feedback = { id : edit_or_state_id; @@ -45,140 +45,6 @@ type feedback = { let default_route = 0 -(** Feedback and logging *) -open Pp -open Pp_control - -type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit - -let msgnl_with ?pp_tag fmt strm = - pp_with ?pp_tag fmt (strm ++ fnl ()); - Format.pp_print_flush fmt () - -(* XXX: This is really painful! *) -module Emacs = struct - - (* Special chars for emacs, to detect warnings inside goal output *) - let emacs_quote_start = String.make 1 (Char.chr 254) - let emacs_quote_end = String.make 1 (Char.chr 255) - - let emacs_quote_err g = - hov 0 (str emacs_quote_start ++ g ++ str emacs_quote_end) - - let emacs_quote_info_start = "" - let emacs_quote_info_end = "" - - let emacs_quote_info g = - hov 0 (str emacs_quote_info_start++ brk(0,0) ++ g ++ brk(0,0) ++ str emacs_quote_info_end) - -end - -open Emacs - -let dbg_str = tag Ppstyle.debug_tag (str "Debug:") ++ spc () -let info_str = mt () -let warn_str = tag Ppstyle.warning_tag (str "Warning:") ++ spc () -let err_str = tag Ppstyle.error_tag (str "Error:" ) ++ spc () - -let make_body quoter info ?loc s = - let loc = Option.cata Pp.pr_loc (Pp.mt ()) loc in - quoter (hov 0 (loc ++ info ++ s)) - -(* Generic logger *) -let gen_logger dbg err ?pp_tag ?loc level msg = match level with - | Debug -> msgnl_with ?pp_tag !std_ft (make_body dbg dbg_str ?loc msg) - | Info -> msgnl_with ?pp_tag !std_ft (make_body dbg info_str ?loc msg) - | Notice -> msgnl_with ?pp_tag !std_ft msg - | Warning -> Flags.if_warn (fun () -> - msgnl_with ?pp_tag !err_ft (make_body err warn_str ?loc msg)) () - | Error -> msgnl_with ?pp_tag !err_ft (make_body err err_str ?loc msg) - -(* We provide a generic clear_log_backend callback for backends - wanting to do clenaup after the print. -*) -let std_logger_tag = ref None -let std_logger_cleanup = ref (fun () -> ()) - -let std_logger ?loc level msg = - gen_logger (fun x -> x) (fun x -> x) ?pp_tag:!std_logger_tag ?loc level msg; - !std_logger_cleanup () - -(* Rules for emacs: - - Debug/info: emacs_quote_info - - Warning/Error: emacs_quote_err - - Notice: unquoted - - Note the inconsistency. - *) -let emacs_logger = gen_logger emacs_quote_info emacs_quote_err ?pp_tag:None - -(** Color logging. Moved from pp_style, it may need some more refactoring *) - -(** Not thread-safe. We should put a lock somewhere if we print from - different threads. Do we? *) -let make_style_stack () = - (** Default tag is to reset everything *) - let empty = Terminal.make () in - let default_tag = Terminal.({ - fg_color = Some `DEFAULT; - bg_color = Some `DEFAULT; - bold = Some false; - italic = Some false; - underline = Some false; - negative = Some false; - }) - in - let style_stack = ref [] in - let peek () = match !style_stack with - | [] -> default_tag (** Anomalous case, but for robustness *) - | st :: _ -> st - in - let push tag = - let style = match Ppstyle.get_style_format tag with - | None -> empty - | Some st -> st - in - (** Use the merging of the latest tag and the one being currently pushed. - This may be useful if for instance the latest tag changes the background and - the current one the foreground, so that the two effects are additioned. *) - let style = Terminal.merge (peek ()) style in - style_stack := style :: !style_stack; - Terminal.eval style - in - let pop _ = match !style_stack with - | [] -> (** Something went wrong, we fallback *) - Terminal.eval default_tag - | _ :: rem -> style_stack := rem; - Terminal.eval (peek ()) - in - let clear () = style_stack := [] in - push, pop, clear - -let init_color_output () = - let open Pp_control in - let push_tag, pop_tag, clear_tag = make_style_stack () in - std_logger_cleanup := clear_tag; - std_logger_tag := Some Ppstyle.to_format; - let tag_handler = { - Format.mark_open_tag = push_tag; - Format.mark_close_tag = pop_tag; - Format.print_open_tag = ignore; - Format.print_close_tag = ignore; - } in - Format.pp_set_mark_tags !std_ft true; - Format.pp_set_mark_tags !err_ft true; - Format.pp_set_formatter_tag_functions !std_ft tag_handler; - Format.pp_set_formatter_tag_functions !err_ft tag_handler - -let logger = ref std_logger -let set_logger l = logger := l - -let msg_info ?loc x = !logger ?loc Info x -let msg_notice ?loc x = !logger ?loc Notice x -let msg_warning ?loc x = !logger ?loc Warning x -let msg_error ?loc x = !logger ?loc Error x -let msg_debug ?loc x = !logger ?loc Debug x - (** Feeders *) let feeders : (int, feedback -> unit) Hashtbl.t = Hashtbl.create 7 @@ -190,11 +56,6 @@ let add_feeder = let del_feeder fid = Hashtbl.remove feeders fid -let debug_feeder = function - | { contents = Message (Debug, loc, pp) } -> - msg_debug ?loc (Pp.str (Richpp.raw_print pp)) - | _ -> () - let feedback_id = ref (Edit 0) let feedback_route = ref default_route @@ -209,32 +70,16 @@ let feedback ?id ?route what = } in Hashtbl.iter (fun _ f -> f m) feeders +(* Logging messages *) let feedback_logger ?loc lvl msg = - feedback ~route:!feedback_route ~id:!feedback_id - (Message (lvl, loc, Richpp.richpp_of_pp msg)) + feedback ~route:!feedback_route ~id:!feedback_id (Message (lvl, loc, msg)) -(* Output to file *) -let ft_logger old_logger ft ?loc level mesg = - let id x = x in - match level with - | Debug -> msgnl_with ft (make_body id dbg_str mesg) - | Info -> msgnl_with ft (make_body id info_str mesg) - | Notice -> msgnl_with ft mesg - | Warning -> old_logger ?loc level mesg - | Error -> old_logger ?loc level mesg - -let with_output_to_file fname func input = - let old_logger = !logger in - let channel = open_out (String.concat "." [fname; "out"]) in - logger := ft_logger old_logger (Format.formatter_of_out_channel channel); - try - let output = func input in - logger := old_logger; - close_out channel; - output - with reraise -> - let reraise = Backtrace.add_backtrace reraise in - logger := old_logger; - close_out channel; - Exninfo.iraise reraise +let msg_info ?loc x = feedback_logger ?loc Info x +let msg_notice ?loc x = feedback_logger ?loc Notice x +let msg_warning ?loc x = feedback_logger ?loc Warning x +let msg_error ?loc x = feedback_logger ?loc Error x +let msg_debug ?loc x = feedback_logger ?loc Debug x +let debug_feeder = function + | { contents = Message (Debug, loc, pp) } -> msg_debug ?loc pp + | _ -> () diff --git a/lib/feedback.mli b/lib/feedback.mli index 8eae31588..3fb7c0039 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -8,7 +8,7 @@ open Xml_datatype -(* Old plain messages (used to be in Pp) *) +(* Legacy-style logging messages (used to be in Pp) *) type level = | Debug | Info @@ -16,7 +16,6 @@ type level = | Warning | Error - (** Coq "semantic" infos obtained during parsing/execution *) type edit_id = int type state_id = Stateid.t @@ -44,7 +43,7 @@ type feedback_content = (* Extra metadata *) | Custom of Loc.t * string * xml (* Generic messages *) - | Message of level * Loc.t option * Richpp.richpp + | Message of level * Loc.t option * Pp.std_ppcmds type feedback = { id : edit_or_state_id; (* The document part concerned *) @@ -53,32 +52,12 @@ type feedback = { } (** {6 Feedback sent, even asynchronously, to the user interface} *) - -(** Moved here from pp.ml *) - (* Morally the parser gets a string and an edit_id, and gives back an AST. * Feedbacks during the parsing phase are attached to this edit_id. * The interpreter assignes an exec_id to the ast, and feedbacks happening * during interpretation are attached to the exec_id. * Only one among state_id and edit_id can be provided. *) -(** A [logger] takes a level plus a pretty printing doc and logs it *) -type logger = ?loc:Loc.t -> level -> Pp.std_ppcmds -> unit - -(** [set_logger l] makes the [msg_*] to use [l] for logging *) -val set_logger : logger -> unit - -(** [std_logger] standard logger to [stdout/stderr] *) -val std_logger : logger - -(** [init_color_output ()] Enable color in the std_logger *) -val init_color_output : unit -> unit - -(** [feedback_logger] will produce feedback messages instead IO events *) -val feedback_logger : logger -val emacs_logger : logger - - (** [add_feeder f] adds a feeder listiner [f], returning its id *) val add_feeder : (feedback -> unit) -> int @@ -97,10 +76,6 @@ val feedback : (** [set_id_for_feedback route id] Set the defaults for feedback *) val set_id_for_feedback : ?route:route_id -> edit_or_state_id -> unit -(** [with_output_to_file file f x] executes [f x] with logging - redirected to a file [file] *) -val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b - (** {6 output functions} [msg_notice] do not put any decoration on output by default. If @@ -128,7 +103,3 @@ val msg_error : ?loc:Loc.t -> Pp.std_ppcmds -> unit val msg_debug : ?loc:Loc.t -> Pp.std_ppcmds -> unit (** For debugging purposes *) - - - - diff --git a/lib/pp.ml b/lib/pp.ml index d763767dc..5dba0356d 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp_control - (* The different kinds of blocks are: \begin{description} \item[hbox:] Horizontal block no line breaking; @@ -178,10 +176,9 @@ let pp_with ?pp_tag ft = | Ppcmd_glue sl -> List.iter pp_cmd sl | Ppcmd_string str -> let n = utf8_length str in pp_print_as ft n str - | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *) - cpp_open_box bty ; - if not (Format.over_max_boxes ()) then pp_cmd ss; - Format.pp_close_box ft () + | Ppcmd_box(bty,ss) -> cpp_open_box bty ; + if not (over_max_boxes ()) then pp_cmd ss; + pp_close_box ft () | Ppcmd_print_break(m,n) -> pp_print_break ft m n | Ppcmd_force_newline -> pp_force_newline ft () | Ppcmd_comment coms -> List.iter (pr_com ft) coms diff --git a/lib/pp.mli b/lib/pp.mli index 5bf5391d3..12747d3a1 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -8,6 +8,30 @@ (** Coq document type. *) +(** Pretty printing guidelines ******************************************) +(* *) +(* std_ppcmds is the main pretty printing datatype in he Coq. Documents *) +(* are composed laying out boxes, and users can add arbitrary metadata *) +(* that backends are free to interpret. *) +(* *) +(* The datatype is public to allow serialization or advanced uses, *) +(* regular users are _strongly_ encouraged to use the top-level *) +(* functions to manipulate the type. *) +(* *) +(* Box order and number is indeed an important factor. Users should try *) +(* to create a proper amount of boxes. Also, the ++ operator provides *) +(* "efficient" concatenation, but directly using a list is preferred. *) +(* *) +(* That is to say, this: *) +(* *) +(* `hov [str "Term"; hov (pr_term t); str "is defined"]` *) +(* *) +(* is preferred to: *) +(* *) +(* `hov (str "Term" ++ hov (pr_term t) ++ str "is defined")` *) +(* *) +(************************************************************************) + (* XXX: Improve and add attributes *) type pp_tag = string list diff --git a/lib/pp_control.ml b/lib/pp_control.ml deleted file mode 100644 index ab8dc0798..000000000 --- a/lib/pp_control.ml +++ /dev/null @@ -1,93 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* pp_global_params -> unit - * set the parameters of a formatter *) - -let set_gp ft gp = - Format.pp_set_margin ft gp.margin ; - Format.pp_set_max_indent ft gp.max_indent ; - Format.pp_set_max_boxes ft gp.max_depth ; - Format.pp_set_ellipsis_text ft gp.ellipsis - -let set_dflt_gp ft = set_gp ft dflt_gp - -let get_gp ft = - { margin = Format.pp_get_margin ft (); - max_indent = Format.pp_get_max_indent ft (); - max_depth = Format.pp_get_max_boxes ft (); - ellipsis = Format.pp_get_ellipsis_text ft () } - -(* with_fp : 'a pp_formatter_params -> Format.formatter - * returns of formatter for given formatter functions *) - -let with_fp chan out_function flush_function = - let ft = Format.make_formatter out_function flush_function in - Format.pp_set_formatter_out_channel ft chan; - ft - -(* Output on a channel ch *) - -let with_output_to ch = - let ft = with_fp ch (output_substring ch) (fun () -> flush ch) in - set_gp ft deep_gp; - ft - -let std_ft = ref Format.std_formatter -let _ = set_dflt_gp !std_ft - -let err_ft = ref Format.err_formatter -let _ = set_gp !err_ft deep_gp - -let deep_ft = ref (with_output_to stdout) -let _ = set_gp !deep_ft deep_gp - -(* For parametrization through vernacular *) -let default = Format.pp_get_max_boxes !std_ft () -let default_margin = Format.pp_get_margin !std_ft () - -let get_depth_boxes () = Some (Format.pp_get_max_boxes !std_ft ()) -let set_depth_boxes v = - Format.pp_set_max_boxes !std_ft (match v with None -> default | Some v -> v) - -let get_margin () = Some (Format.pp_get_margin !std_ft ()) -let set_margin v = - let v = match v with None -> default_margin | Some v -> v in - Format.pp_set_margin Format.str_formatter v; - Format.pp_set_margin !std_ft v; - Format.pp_set_margin !deep_ft v; - (* Heuristic, based on usage: the column on the right of max_indent - column is 20% of width, capped to 30 characters *) - let m = max (64 * v / 100) (v-30) in - Format.pp_set_max_indent Format.str_formatter m; - Format.pp_set_max_indent !std_ft m; - Format.pp_set_max_indent !deep_ft m diff --git a/lib/pp_control.mli b/lib/pp_control.mli deleted file mode 100644 index d26f89eb3..000000000 --- a/lib/pp_control.mli +++ /dev/null @@ -1,38 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* pp_global_params -> unit -val set_dflt_gp : Format.formatter -> unit -val get_gp : Format.formatter -> pp_global_params - - -(** {6 Output functions of pretty-printing. } *) - -val with_output_to : out_channel -> Format.formatter - -val std_ft : Format.formatter ref -val err_ft : Format.formatter ref -val deep_ft : Format.formatter ref - -(** {6 For parametrization through vernacular. } *) - -val set_depth_boxes : int option -> unit -val get_depth_boxes : unit -> int option - -val set_margin : int option -> unit -val get_margin : unit -> int option diff --git a/lib/richpp.ml b/lib/richpp.ml deleted file mode 100644 index c0128dbc2..000000000 --- a/lib/richpp.ml +++ /dev/null @@ -1,200 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* assert false - | Node (node, child, pos, ctx) -> - let data = Buffer.contents pp_buffer in - let () = Buffer.clear pp_buffer in - let () = context.stack <- Node (node, PCData data :: child, pos, ctx) in - context.offset <- context.offset + len - in - - let open_xml_tag tag = - let () = push_pcdata () in - context.stack <- Node (tag, [], context.offset, context.stack) - in - - let close_xml_tag tag = - let () = push_pcdata () in - match context.stack with - | Leaf -> assert false - | Node (node, child, pos, ctx) -> - let () = assert (String.equal tag node) in - let annotation = - try Int.Map.find (int_of_string node) context.annotations - with _ -> None - in - let annotation = { - annotation = annotation; - startpos = pos; - endpos = context.offset; - } in - let xml = Element (node, annotation, List.rev child) in - match ctx with - | Leaf -> - (** Final node: we keep the result in a dummy context *) - context.stack <- Node ("", [xml], 0, Leaf) - | Node (node, child, pos, ctx) -> - context.stack <- Node (node, xml :: child, pos, ctx) - in - - let open Format in - - let ft = formatter_of_buffer pp_buffer in - - let tag_functions = { - mark_open_tag = (fun tag -> let () = open_xml_tag tag in ""); - mark_close_tag = (fun tag -> let () = close_xml_tag tag in ""); - print_open_tag = ignore; - print_close_tag = ignore; - } in - - pp_set_formatter_tag_functions ft tag_functions; - pp_set_mark_tags ft true; - - (* Set formatter width. This is currently a hack and duplicate code - with Pp_control. Hopefully it will be fixed better in Coq 8.7 *) - let w = pp_get_margin str_formatter () in - let m = max (64 * w / 100) (w-30) in - pp_set_margin ft w; - pp_set_max_indent ft m; - - (** The whole output must be a valid document. To that - end, we nest the document inside tags. *) - pp_open_tag ft "pp"; - Pp.(pp_with ~pp_tag ft ppcmds); - pp_close_tag ft (); - - (** Get the resulting XML tree. *) - let () = pp_print_flush ft () in - let () = assert (Buffer.length pp_buffer = 0) in - match context.stack with - | Node ("", [xml], 0, Leaf) -> xml - | _ -> assert false - - -let annotations_positions xml = - let rec node accu = function - | Element (_, { annotation = Some annotation; startpos; endpos }, cs) -> - children ((annotation, (startpos, endpos)) :: accu) cs - | Element (_, _, cs) -> - children accu cs - | _ -> - accu - and children accu cs = - List.fold_left node accu cs - in - node [] xml - -let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml = - let rec node = function - | Element (index, { annotation; startpos; endpos }, cs) -> - let attributes = - [ "startpos", string_of_int startpos; - "endpos", string_of_int endpos - ] - @ (match annotation with - | None -> [] - | Some annotation -> attributes_of_annotation annotation - ) - in - let tag = - match annotation with - | None -> index - | Some annotation -> tag_of_annotation annotation - in - Element (tag, attributes, List.map node cs) - | PCData s -> - PCData s - in - node xml - -type richpp = xml - -let repr xml = xml -let richpp_of_xml xml = xml -let richpp_of_string s = PCData s - -let richpp_of_pp pp = - let annotate t = Some (Ppstyle.repr t) in - let rec drop = function - | PCData s -> [PCData s] - | Element (_, annotation, cs) -> - let cs = List.concat (List.map drop cs) in - match annotation.annotation with - | None -> cs - | Some s -> [Element (String.concat "." s, [], cs)] - in - let xml = rich_pp annotate pp in - Element ("_", [], drop xml) - -let raw_print xml = - let buf = Buffer.create 1024 in - let rec print = function - | PCData s -> Buffer.add_string buf s - | Element (_, _, cs) -> List.iter print cs - in - let () = print xml in - Buffer.contents buf - diff --git a/lib/richpp.mli b/lib/richpp.mli deleted file mode 100644 index 2e839e996..000000000 --- a/lib/richpp.mli +++ /dev/null @@ -1,64 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'annotation option) -> Pp.std_ppcmds -> - 'annotation located Xml_datatype.gxml - -(** [annotations_positions ssdoc] returns a list associating each - annotations with its position in the string from which [ssdoc] is - built. *) -val annotations_positions : - 'annotation located Xml_datatype.gxml -> - ('annotation * (int * int)) list - -(** [xml_of_rich_pp ssdoc] returns an XML representation of the - semi-structured document [ssdoc]. *) -val xml_of_rich_pp : - ('annotation -> string) -> - ('annotation -> (string * string) list) -> - 'annotation located Xml_datatype.gxml -> - Xml_datatype.xml - -(** {5 Enriched text} *) - -type richpp -(** Type of text with style annotations *) - -val richpp_of_pp : Pp.std_ppcmds -> richpp -(** Extract style information from formatted text *) - -val richpp_of_xml : Xml_datatype.xml -> richpp -(** Do not use outside of dedicated areas *) - -val richpp_of_string : string -> richpp -(** Make a styled text out of a normal string *) - -val repr : richpp -> Xml_datatype.xml -(** Observe the styled text as XML *) - -(** {5 Debug/Compat} *) - -(** Represent the semi-structured document as a string, dropping any additional - information. *) -val raw_print : richpp -> string diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index e019bb3c2..ee623c5ca 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -472,13 +472,14 @@ let formatter dry file = if dry then Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) else match file with - | Some f -> Pp_control.with_output_to f + | Some f -> Topfmt.with_output_to f | None -> Format.formatter_of_buffer buf in + (* XXX: Fixme, this shouldn't depend on Topfmt *) (* We never want to see ellipsis ... in extracted code *) Format.pp_set_max_boxes ft max_int; (* We reuse the width information given via "Set Printing Width" *) - (match Pp_control.get_margin () with + (match Topfmt.get_margin () with | None -> () | Some i -> Format.pp_set_margin ft i; diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 8acc3c233..28548ecee 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -298,18 +298,11 @@ module Make(T : Task) = struct let slave_handshake () = Pool.worker_handshake (Option.get !slave_ic) (Option.get !slave_oc) - let pp_pid pp = - (* Breaking all abstraction barriers... very nice *) - let get_xml pp = match Richpp.repr pp with - | Xml_datatype.Element("_", [], xml) -> xml - | _ -> assert false in - Richpp.richpp_of_xml (Xml_datatype.Element("_", [], - get_xml (Richpp.richpp_of_pp Pp.(str (System.process_id ()^ " "))) @ - get_xml pp)) + let pp_pid pp = Pp.(str (System.process_id () ^ " ") ++ pp) let debug_with_pid = Feedback.(function | { contents = Message(Debug, loc, pp) } as fb -> - { fb with contents = Message(Debug,loc,pp_pid pp) } + { fb with contents = Message(Debug,loc, pp_pid pp) } | x -> x) let main_loop () = @@ -317,7 +310,6 @@ module Make(T : Task) = struct let slave_feeder oc fb = Marshal.to_channel oc (RespFeedback (debug_with_pid fb)) []; flush oc in Feedback.add_feeder (fun x -> slave_feeder (Option.get !slave_oc) x); - Feedback.set_logger Feedback.feedback_logger; (* We ask master to allocate universe identifiers *) Universes.set_remote_new_univ_level (bufferize (fun () -> marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel; diff --git a/stm/stm.ml b/stm/stm.ml index e56db4090..75872d633 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -11,10 +11,6 @@ let pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr let prerr_endline s = if false then begin pr_err (s ()) end else () let prerr_debug s = if !Flags.debug then begin pr_err (s ()) end else () -(* Opening ppvernac below aliases Richpp, see PR#185 *) -let pp_to_richpp = Richpp.richpp_of_pp -let str_to_richpp = Richpp.richpp_of_string - open Vernacexpr open CErrors open Pp @@ -26,7 +22,7 @@ open Feedback let execution_error state_id loc msg = feedback ~id:(State state_id) - (Message (Error, Some loc, pp_to_richpp msg)) + (Message (Error, Some loc, msg)) module Hooks = struct @@ -48,7 +44,7 @@ let forward_feedback, forward_feedback_hook = let parse_error, parse_error_hook = Hook.make ~default:(fun id loc msg -> - feedback ~id (Message(Error, Some loc, pp_to_richpp msg))) () + feedback ~id (Message(Error, Some loc, msg))) () let unreachable_state, unreachable_state_hook = Hook.make ~default:(fun _ _ -> ()) () @@ -1945,7 +1941,7 @@ end = struct (* {{{ *) feedback ~id:(State r_for) Processed with e when CErrors.noncritical e -> let e = CErrors.push e in - let msg = pp_to_richpp (iprint e) in + let msg = iprint e in feedback ~id:(State r_for) (Message (Error, None, msg)) let name_of_task { t_what } = string_of_ppcmds (pr_ast t_what) diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out index a2ee2d4c8..979396969 100644 --- a/test-suite/output/Arguments.out +++ b/test-suite/output/Arguments.out @@ -97,8 +97,8 @@ Expands to: Constant Top.f forall w : r, w 3 true = tt : Prop The command has indeed failed with message: -Error: Unknown interpretation for notation "$". +Unknown interpretation for notation "$". w 3 true = tt : Prop The command has indeed failed with message: -Error: Extra arguments: _, _. +Extra arguments: _, _. diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index b084ad498..4df21ae35 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -1,5 +1,5 @@ The command has indeed failed with message: -Error: To rename arguments the "rename" flag must be specified. +To rename arguments the "rename" flag must be specified. Argument A renamed to B. File "stdin", line 2, characters 0-25: Warning: This command is just asserting the names of arguments of identity. @@ -103,15 +103,15 @@ Expands to: Constant Top.myplus @myplus : forall Z : Type, Z -> nat -> nat -> nat The command has indeed failed with message: -Error: Argument lists should agree on the names they provide. +Argument lists should agree on the names they provide. The command has indeed failed with message: -Error: Sequences of implicit arguments must be of different lengths. +Sequences of implicit arguments must be of different lengths. The command has indeed failed with message: -Error: Some argument names are duplicated: F +Some argument names are duplicated: F The command has indeed failed with message: -Error: Argument z cannot be declared implicit. +Argument z cannot be declared implicit. The command has indeed failed with message: -Error: Extra arguments: y. +Extra arguments: y. The command has indeed failed with message: -Error: To rename arguments the "rename" flag must be specified. +To rename arguments the "rename" flag must be specified. Argument A renamed to R. diff --git a/test-suite/output/Errors.out b/test-suite/output/Errors.out index 06a6b2d15..38d055b28 100644 --- a/test-suite/output/Errors.out +++ b/test-suite/output/Errors.out @@ -7,4 +7,4 @@ In nested Ltac calls to "f" and "apply x", last call failed. Unable to unify "nat" with "True". The command has indeed failed with message: Ltac call to "instantiate ( (ident) := (lglob) )" failed. -Error: Instance is not well-typed in the environment of ?x. +Instance is not well-typed in the environment of ?x. diff --git a/test-suite/output/FunExt.out b/test-suite/output/FunExt.out index c6786c72f..8d2a125c1 100644 --- a/test-suite/output/FunExt.out +++ b/test-suite/output/FunExt.out @@ -16,4 +16,4 @@ Tactic failure: Already an intensional equality. The command has indeed failed with message: In nested Ltac calls to "extensionality in (var)" and "clearbody (ne_var_list)", last call failed. -Error: Hypothesis e depends on the body of H' +Hypothesis e depends on the body of H' diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index 26eaca827..9d106d2da 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -41,29 +41,29 @@ fun x : nat => ifn x is succ n then n else 0 -4 : Z The command has indeed failed with message: -Error: x should not be bound in a recursive pattern of the right-hand side. +x should not be bound in a recursive pattern of the right-hand side. The command has indeed failed with message: -Error: in the right-hand side, y and z should appear in +in the right-hand side, y and z should appear in term position as part of a recursive pattern. The command has indeed failed with message: The reference w was not found in the current environment. The command has indeed failed with message: -Error: in the right-hand side, y and z should appear in +in the right-hand side, y and z should appear in term position as part of a recursive pattern. The command has indeed failed with message: -Error: z is expected to occur in binding position in the right-hand side. +z is expected to occur in binding position in the right-hand side. The command has indeed failed with message: -Error: as y is a non-closed binder, no such "," is allowed to occur. +as y is a non-closed binder, no such "," is allowed to occur. The command has indeed failed with message: -Error: Cannot find where the recursive pattern starts. +Cannot find where the recursive pattern starts. The command has indeed failed with message: -Error: Cannot find where the recursive pattern starts. +Cannot find where the recursive pattern starts. The command has indeed failed with message: -Error: Cannot find where the recursive pattern starts. +Cannot find where the recursive pattern starts. The command has indeed failed with message: -Error: Cannot find where the recursive pattern starts. +Cannot find where the recursive pattern starts. The command has indeed failed with message: -Error: Both ends of the recursive pattern are the same. +Both ends of the recursive pattern are the same. SUM (nat * nat) nat : Set FST (0; 1) diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out index 1ff09e3af..35c3057d8 100644 --- a/test-suite/output/ltac.out +++ b/test-suite/output/ltac.out @@ -1,5 +1,4 @@ The command has indeed failed with message: -Error: Ltac variable y depends on pattern variable name z which is not bound in current context. Ltac f x y z := symmetry in x, y; auto with z; auto; intros **; clearbody x; generalize @@ -22,11 +21,11 @@ The term "I" has type "True" while it is expected to have type "False". The command has indeed failed with message: In nested Ltac calls to "h" and "injection (destruction_arg)", last call failed. -Error: No primitive equality found. +No primitive equality found. The command has indeed failed with message: In nested Ltac calls to "h" and "injection (destruction_arg)", last call failed. -Error: No primitive equality found. +No primitive equality found. Hx nat nat diff --git a/test-suite/output/ltac_missing_args.out b/test-suite/output/ltac_missing_args.out index ae3fd7acc..172612405 100644 --- a/test-suite/output/ltac_missing_args.out +++ b/test-suite/output/ltac_missing_args.out @@ -1,21 +1,20 @@ The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable x. +A fully applied tactic is expected: missing argument for variable x. The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable x. +A fully applied tactic is expected: missing argument for variable x. The command has indeed failed with message: -Error: A fully applied tactic is expected: -missing arguments for variables y and _. +A fully applied tactic is expected: missing arguments for variables y and _. The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable x. +A fully applied tactic is expected: missing argument for variable x. The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable x. +A fully applied tactic is expected: missing argument for variable x. The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable _. +A fully applied tactic is expected: missing argument for variable _. The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable _. +A fully applied tactic is expected: missing argument for variable _. The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable _. +A fully applied tactic is expected: missing argument for variable _. The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable x. +A fully applied tactic is expected: missing argument for variable x. The command has indeed failed with message: -Error: A fully applied tactic is expected: missing argument for variable x. +A fully applied tactic is expected: missing argument for variable x. diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index 23c111b37..e89f19041 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -29,7 +29,7 @@ let error_xml s = exit 1 let logger level content = - Printf.eprintf "%a\n%! " print_xml (Richpp.repr content) + Printf.eprintf "%a\n%! " print_xml Richpp.(content |> richpp_of_pp |> repr) let base_eval_call ?(print=true) ?(fail=true) call coqtop = if print then prerr_endline (Xmlprotocol.pr_call call); @@ -44,8 +44,8 @@ let base_eval_call ?(print=true) ?(fail=true) call coqtop = let res = loop () in if print then prerr_endline (Xmlprotocol.pr_full_value call res); match res with - | Interface.Fail (_,_,s) when fail -> error_xml (Richpp.repr s) - | Interface.Fail (_,_,s) as x -> Printf.eprintf "%a\n%!" print_xml (Richpp.repr s); x + | Interface.Fail (_,_,s) when fail -> error_xml Richpp.(s |> richpp_of_pp |> repr) + | Interface.Fail (_,_,s) as x -> Printf.eprintf "%a\n%!" print_xml Richpp.(s |> richpp_of_pp |> repr); x | x -> x let eval_call c q = ignore(base_eval_call c q) @@ -194,7 +194,7 @@ let print_document () = module GUILogic = struct let after_add = function - | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) + | Interface.Fail (_,_,s) -> error_xml Richpp.(repr (richpp_of_pp s)) | Interface.Good (id, (Util.Inl (), _)) -> Document.assign_tip_id doc id | Interface.Good (id, (Util.Inr tip, _)) -> @@ -206,7 +206,7 @@ module GUILogic = struct let at id id' _ = Stateid.equal id' id let after_edit_at (id,need_unfocus) = function - | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) + | Interface.Fail (_,_,s) -> error_xml Richpp.(repr (richpp_of_pp s)) | Interface.Good (Util.Inl ()) -> if need_unfocus then Document.unfocus doc; ignore(Document.cut_at doc id); @@ -329,7 +329,7 @@ let main = let finish () = match base_eval_call (Xmlprotocol.status true) coq with | Interface.Good _ -> exit 0 - | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) in + | Interface.Fail (_,_,s) -> error_xml Richpp.(repr (richpp_of_pp s)) in (* The main loop *) init (); while true do diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 2cb608326..e9506803d 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -14,8 +14,7 @@ open Vernac open Pcoq let top_stderr x = - pp_with ~pp_tag:Ppstyle.to_format !Pp_control.err_ft x; - Format.pp_print_flush !Pp_control.err_ft () + Format.fprintf !Topfmt.err_ft "@[%a@]%!" (pp_with ~pp_tag:Ppstyle.to_format) x (* A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) @@ -253,7 +252,8 @@ let print_toplevel_error (e, info) = else mt () else print_location_in_file loc in - locmsg ++ CErrors.iprint (e, info) + let hdr msg = hov 0 (tag Ppstyle.error_tag (str "Error:") ++ spc () ++ msg) in + locmsg ++ hdr (CErrors.iprint (e, info)) (* Read the input stream until a dot is encountered *) let parse_to_dot = @@ -285,6 +285,33 @@ let read_sentence input = discard_to_dot (); iraise reraise +(** Coqloop Console feedback handler *) +let coqloop_feed (fb : Feedback.feedback) = let open Feedback in + match fb.contents with + | Processed -> () + | Incomplete -> () + | Complete -> () + | ProcessingIn _ -> () + | InProgress _ -> () + | WorkerStatus (_,_) -> () + | AddedAxiom -> () + | GlobRef (_,_,_,_,_) -> () + | GlobDef (_,_,_,_) -> () + | FileDependency (_,_) -> () + | FileLoaded (_,_) -> () + | Custom (_,_,_) -> () + | Message (Error,loc,msg) -> + (* We ignore errors here as we (still) have a different error + printer for the toplevel. It is hard to solve due the many + error paths presents, and the different compromise of feedback + error forwaring in the stm depending on the mode *) + () + | Message (lvl,loc,msg) -> + if !Flags.print_emacs then + Topfmt.emacs_logger ?loc lvl msg + else + Topfmt.std_logger ?loc lvl msg + (** [do_vernac] reads and executes a toplevel phrase, and print error messages when an exception is raised, except for the following: - Drop: kill the Coq toplevel, going down to the Caml toplevel if it exists. @@ -307,12 +334,13 @@ let do_vernac () = top_stderr (fnl ()); raise CErrors.Quit | CErrors.Drop -> (* Last chance *) if Mltop.is_ocaml_top() then raise CErrors.Drop - else Feedback.msg_error (str"There is no ML toplevel.") + else top_stderr (str "There is no ML toplevel.") | any -> + (** Main error printer, note that this didn't it the "emacs" + legacy path. *) let any = CErrors.push any in let msg = print_toplevel_error any ++ fnl () in - pp_with !Pp_control.std_ft msg; - Format.pp_print_flush !Pp_control.std_ft () + top_stderr msg (** Main coq loop : read vernacular expressions until Drop is entered. Ctrl-C is handled internally as Sys.Break instead of aborting Coq. @@ -320,22 +348,13 @@ let do_vernac () = exit the loop are Drop and Quit. Any other exception there indicates an issue with [print_toplevel_error] above. *) -(* -let feed_emacs = function - | { Interface.id = Interface.State id; - Interface.content = Interface.GlobRef (_,a,_,c,_) } -> - prerr_endline ("" ^""^Stateid.to_string id ^"" - ^a^" "^c^ "") - | _ -> () -*) - (* Flush in a compatible order with 8.5 *) (* This mimics the semantics of the old Pp.flush_all *) let loop_flush_all () = Pervasives.flush stderr; Pervasives.flush stdout; - Format.pp_print_flush !Pp_control.std_ft (); - Format.pp_print_flush !Pp_control.err_ft () + Format.pp_print_flush !Topfmt.std_ft (); + Format.pp_print_flush !Topfmt.err_ft () let rec loop () = Sys.catch_break true; @@ -348,9 +367,9 @@ let rec loop () = | CErrors.Drop -> () | CErrors.Quit -> exit 0 | any -> - Feedback.msg_error (str"Anomaly: main loop exited with exception: " ++ - str (Printexc.to_string any) ++ - fnl() ++ - str"Please report" ++ - strbrk" at " ++ str Coq_config.wwwbugtracker ++ str "."); + top_stderr (str"Anomaly: main loop exited with exception: " ++ + str (Printexc.to_string any) ++ + fnl() ++ + str"Please report" ++ + strbrk" at " ++ str Coq_config.wwwbugtracker ++ str "."); loop () diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli index d248f2f70..eb61084e0 100644 --- a/toplevel/coqloop.mli +++ b/toplevel/coqloop.mli @@ -32,6 +32,8 @@ val set_prompt : (unit -> string) -> unit val print_toplevel_error : Exninfo.iexn -> std_ppcmds +val coqloop_feed : Feedback.feedback -> unit + (** Parse and execute one vernac command. *) val do_vernac : unit -> unit diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 541c1fd1b..823d05580 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -61,7 +61,7 @@ let init_color () = match colors with | None -> (** Default colors *) - Feedback.init_color_output () + Topfmt.init_color_output () | Some "" -> (** No color output *) () @@ -69,7 +69,7 @@ let init_color () = (** Overwrite all colors *) Ppstyle.clear_styles (); Ppstyle.parse_config s; - Feedback.init_color_output () + Topfmt.init_color_output () end let toploop_init = ref begin fun x -> @@ -78,15 +78,27 @@ let toploop_init = ref begin fun x -> x end -let toploop_run = ref (fun () -> +(* Feedback received in the init stage, this is different as the STM + will not be generally be initialized, thus stateid, etc... may be + bogus. For now we just print to the console too *) +let coqtop_init_feed = Coqloop.coqloop_feed + +(* Default toplevel loop *) +let console_toploop_run () = + (* We initialize the console only if we run the toploop_run *) + let tl_feed = Feedback.add_feeder Coqloop.coqloop_feed in if Dumpglob.dump () then begin if_verbose warning "Dumpglob cannot be used in interactive mode."; Dumpglob.noglob () end; Coqloop.loop(); + (* We remove the feeder but it could be ok not to do so *) + Feedback.del_feeder tl_feed; (* Initialise and launch the Ocaml toplevel *) Coqinit.init_ocaml_path(); - Mltop.ocaml_toploop()) + Mltop.ocaml_toploop() + +let toploop_run = ref console_toploop_run let output_context = ref false @@ -228,7 +240,6 @@ let compile_files () = if !compile_list == [] then () else let init_state = States.freeze ~marshallable:`No in - Feedback.(add_feeder debug_feeder); List.iter (fun vf -> States.unfreeze init_state; compile_file vf) @@ -240,7 +251,6 @@ let set_emacs () = if not (Option.is_empty !toploop) then error "Flag -emacs is incompatible with a custom toplevel loop"; Flags.print_emacs := true; - Feedback.(set_logger emacs_logger); Vernacentries.qed_display_script := false; color := `OFF @@ -435,7 +445,7 @@ let get_native_name s = with the appropriate error code *) let fatal_error info anomaly = let msg = info ++ fnl () in - Format.fprintf !Topfmt.err_ft "@[%a@]%!" pp_with msg; + Format.fprintf !Topfmt.err_ft "@[%a@]%!" (pp_with ?pp_tag:None) msg; exit (if anomaly then 129 else 1) let parse_args arglist = @@ -609,6 +619,7 @@ let parse_args arglist = let init_toplevel arglist = init_gc (); Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) + let init_feeder = Feedback.add_feeder coqtop_init_feed in Lib.init(); begin try @@ -663,7 +674,8 @@ let init_toplevel arglist = Feedback.msg_notice (with_option raw_print Prettyp.print_full_pure_context () ++ fnl ()); Profile.print_profile (); exit 0 - end + end; + Feedback.del_feeder init_feeder let start () = let () = init_toplevel (List.tl (Array.to_list Sys.argv)) in diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 5d17054fc..4fc4540c1 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -143,8 +143,8 @@ let pr_new_syntax_in_context loc chan_beautify ocom = | None -> mt() in let after = comment (CLexer.extract_comments (snd loc)) in if !beautify_file then - (Pp.pp_with !Pp_control.std_ft (hov 0 (before ++ com ++ after)); - Format.pp_print_flush !Pp_control.std_ft ()) + (Pp.pp_with !Topfmt.std_ft (hov 0 (before ++ com ++ after)); + Format.pp_print_flush !Topfmt.std_ft ()) else Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); States.unfreeze fs; @@ -179,9 +179,10 @@ let pp_cmd_header loc com = (* This is a special case where we assume we are in console batch mode and take control of the console. *) +(* FIXME *) let print_cmd_header loc com = - Pp.pp_with ~pp_tag:Ppstyle.to_format !Pp_control.std_ft (pp_cmd_header loc com); - Format.pp_print_flush !Pp_control.std_ft () + Pp.pp_with ~pp_tag:Ppstyle.to_format !Topfmt.std_ft (pp_cmd_header loc com); + Format.pp_print_flush !Topfmt.std_ft () let rec interp_vernac po chan_beautify checknav (loc,com) = let interp = function diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 5b91af03c..f1e0c48f0 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -45,15 +45,9 @@ let _ = CErrors.register_handler explain_exn_default (** Pre-explain a vernac interpretation error *) -let wrap_vernac_error with_header (exn, info) strm = - if with_header then - let header = Pp.tag Ppstyle.error_tag (str "Error:") in - let e = EvaluatedError (hov 0 (header ++ spc () ++ strm), None) in - (e, info) - else - (EvaluatedError (strm, None), info) +let wrap_vernac_error (exn, info) strm = (EvaluatedError (strm, None), info) -let process_vernac_interp_error with_header exn = match fst exn with +let process_vernac_interp_error exn = match fst exn with | Univ.UniverseInconsistency i -> let msg = if !Constrextern.print_universes then @@ -61,40 +55,40 @@ let process_vernac_interp_error with_header exn = match fst exn with Univ.explain_universe_inconsistency Universes.pr_with_global_universes i else mt() in - wrap_vernac_error with_header exn (str "Universe inconsistency" ++ msg ++ str ".") + wrap_vernac_error exn (str "Universe inconsistency" ++ msg ++ str ".") | TypeError(ctx,te) -> - wrap_vernac_error with_header exn (Himsg.explain_type_error ctx Evd.empty te) + wrap_vernac_error exn (Himsg.explain_type_error ctx Evd.empty te) | PretypeError(ctx,sigma,te) -> - wrap_vernac_error with_header exn (Himsg.explain_pretype_error ctx sigma te) + wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te) | Typeclasses_errors.TypeClassError(env, te) -> - wrap_vernac_error with_header exn (Himsg.explain_typeclass_error env te) + wrap_vernac_error exn (Himsg.explain_typeclass_error env te) | InductiveError e -> - wrap_vernac_error with_header exn (Himsg.explain_inductive_error e) + wrap_vernac_error exn (Himsg.explain_inductive_error e) | Modops.ModuleTypingError e -> - wrap_vernac_error with_header exn (Himsg.explain_module_error e) + wrap_vernac_error exn (Himsg.explain_module_error e) | Modintern.ModuleInternalizationError e -> - wrap_vernac_error with_header exn (Himsg.explain_module_internalization_error e) + wrap_vernac_error exn (Himsg.explain_module_internalization_error e) | RecursionSchemeError e -> - wrap_vernac_error with_header exn (Himsg.explain_recursion_scheme_error e) + wrap_vernac_error exn (Himsg.explain_recursion_scheme_error e) | Cases.PatternMatchingError (env,sigma,e) -> - wrap_vernac_error with_header exn (Himsg.explain_pattern_matching_error env sigma e) + wrap_vernac_error exn (Himsg.explain_pattern_matching_error env sigma e) | Tacred.ReductionTacticError e -> - wrap_vernac_error with_header exn (Himsg.explain_reduction_tactic_error e) + wrap_vernac_error exn (Himsg.explain_reduction_tactic_error e) | Logic.RefinerError e -> - wrap_vernac_error with_header exn (Himsg.explain_refiner_error e) + wrap_vernac_error exn (Himsg.explain_refiner_error e) | Nametab.GlobalizationError q -> - wrap_vernac_error with_header exn + wrap_vernac_error exn (str "The reference" ++ spc () ++ Libnames.pr_qualid q ++ spc () ++ str "was not found" ++ spc () ++ str "in the current" ++ spc () ++ str "environment.") | Refiner.FailError (i,s) -> let s = Lazy.force s in - wrap_vernac_error with_header exn + wrap_vernac_error exn (str "Tactic failure" ++ (if Pp.ismt s then s else str ": " ++ s) ++ if Int.equal i 0 then str "." else str " (level " ++ int i ++ str").") | AlreadyDeclared msg -> - wrap_vernac_error with_header exn (msg ++ str ".") + wrap_vernac_error exn (msg ++ str ".") | _ -> exn @@ -108,9 +102,9 @@ let additional_error_info = ref [] let register_additional_error_info f = additional_error_info := f :: !additional_error_info -let process_vernac_interp_error ?(allow_uncaught=true) ?(with_header=true) (exc, info) = +let process_vernac_interp_error ?(allow_uncaught=true) (exc, info) = let exc = strip_wrapping_exceptions exc in - let e = process_vernac_interp_error with_header (exc, info) in + let e = process_vernac_interp_error (exc, info) in let () = if not allow_uncaught && not (CErrors.handled (fst e)) then let (e, info) = e in diff --git a/vernac/explainErr.mli b/vernac/explainErr.mli index a67c887af..370ad7e3b 100644 --- a/vernac/explainErr.mli +++ b/vernac/explainErr.mli @@ -11,7 +11,7 @@ exception EvaluatedError of Pp.std_ppcmds * exn option (** Pre-explain a vernac interpretation error *) -val process_vernac_interp_error : ?allow_uncaught:bool -> ?with_header:bool -> Util.iexn -> Util.iexn +val process_vernac_interp_error : ?allow_uncaught:bool -> Util.iexn -> Util.iexn (** General explain function. Should not be used directly now, see instead function [Errors.print] and variants *) diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml new file mode 100644 index 000000000..85981c386 --- /dev/null +++ b/vernac/topfmt.ml @@ -0,0 +1,245 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* pp_global_params -> unit + * set the parameters of a formatter *) + +let set_gp ft gp = + Format.pp_set_margin ft gp.margin ; + Format.pp_set_max_indent ft gp.max_indent ; + Format.pp_set_max_boxes ft gp.max_depth ; + Format.pp_set_ellipsis_text ft gp.ellipsis + +let set_dflt_gp ft = set_gp ft dflt_gp + +let get_gp ft = + { margin = Format.pp_get_margin ft (); + max_indent = Format.pp_get_max_indent ft (); + max_depth = Format.pp_get_max_boxes ft (); + ellipsis = Format.pp_get_ellipsis_text ft () } + +(* with_fp : 'a pp_formatter_params -> Format.formatter + * returns of formatter for given formatter functions *) + +let with_fp chan out_function flush_function = + let ft = Format.make_formatter out_function flush_function in + Format.pp_set_formatter_out_channel ft chan; + ft + +(* Output on a channel ch *) + +let with_output_to ch = + let ft = with_fp ch (output_substring ch) (fun () -> flush ch) in + set_gp ft deep_gp; + ft + +let std_ft = ref Format.std_formatter +let _ = set_dflt_gp !std_ft + +let err_ft = ref Format.err_formatter +let _ = set_gp !err_ft deep_gp + +let deep_ft = ref (with_output_to stdout) +let _ = set_gp !deep_ft deep_gp + +(* For parametrization through vernacular *) +let default = Format.pp_get_max_boxes !std_ft () +let default_margin = Format.pp_get_margin !std_ft () + +let get_depth_boxes () = Some (Format.pp_get_max_boxes !std_ft ()) +let set_depth_boxes v = + Format.pp_set_max_boxes !std_ft (match v with None -> default | Some v -> v) + +let get_margin () = Some (Format.pp_get_margin !std_ft ()) +let set_margin v = + let v = match v with None -> default_margin | Some v -> v in + Format.pp_set_margin Format.str_formatter v; + Format.pp_set_margin !std_ft v; + Format.pp_set_margin !deep_ft v; + (* Heuristic, based on usage: the column on the right of max_indent + column is 20% of width, capped to 30 characters *) + let m = max (64 * v / 100) (v-30) in + Format.pp_set_max_indent Format.str_formatter m; + Format.pp_set_max_indent !std_ft m; + Format.pp_set_max_indent !deep_ft m + +(** Console display of feedback *) + +type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit + +let msgnl_with ?pp_tag fmt strm = + pp_with ?pp_tag fmt (strm ++ fnl ()); + Format.pp_print_flush fmt () + +(* XXX: This is really painful! *) +module Emacs = struct + + (* Special chars for emacs, to detect warnings inside goal output *) + let emacs_quote_start = String.make 1 (Char.chr 254) + let emacs_quote_end = String.make 1 (Char.chr 255) + + let emacs_quote_err g = + hov 0 (str emacs_quote_start ++ g ++ str emacs_quote_end) + + let emacs_quote_info_start = "" + let emacs_quote_info_end = "" + + let emacs_quote_info g = + hov 0 (str emacs_quote_info_start++ brk(0,0) ++ g ++ brk(0,0) ++ str emacs_quote_info_end) + +end + +open Emacs + +let dbg_str = tag Ppstyle.debug_tag (str "Debug:") ++ spc () +let info_str = mt () +let warn_str = tag Ppstyle.warning_tag (str "Warning:") ++ spc () +let err_str = tag Ppstyle.error_tag (str "Error:") ++ spc () + +let make_body quoter info ?loc s = + let loc = Option.cata Pp.pr_loc (Pp.mt ()) loc in + quoter (hov 0 (loc ++ info ++ s)) + +(* Generic logger *) +let gen_logger ?pp_tag dbg err ?loc level msg = match level with + | Debug -> msgnl_with ?pp_tag !std_ft (make_body dbg dbg_str ?loc msg) + | Info -> msgnl_with ?pp_tag !std_ft (make_body dbg info_str ?loc msg) + (* XXX: What to do with loc here? *) + | Notice -> msgnl_with ?pp_tag !std_ft msg + | Warning -> Flags.if_warn (fun () -> + msgnl_with ?pp_tag !err_ft (make_body err warn_str ?loc msg)) () + | Error -> msgnl_with ?pp_tag !err_ft (make_body err err_str ?loc msg) + +(** Standard loggers *) + +(* We provide a generic clear_log_backend callback for backends + wanting to do clenaup after the print. +*) +let std_logger_tag = ref None +let std_logger_cleanup = ref (fun () -> ()) + +let std_logger ?loc level msg = + gen_logger (fun x -> x) (fun x -> x) ?pp_tag:!std_logger_tag ?loc level msg; + !std_logger_cleanup () + +(** Color logging. Moved from pp_style, it may need some more refactoring *) + +(** Not thread-safe. We should put a lock somewhere if we print from + different threads. Do we? *) +let make_style_stack () = + (** Default tag is to reset everything *) + let empty = Terminal.make () in + let default_tag = Terminal.({ + fg_color = Some `DEFAULT; + bg_color = Some `DEFAULT; + bold = Some false; + italic = Some false; + underline = Some false; + negative = Some false; + }) + in + let style_stack = ref [] in + let peek () = match !style_stack with + | [] -> default_tag (** Anomalous case, but for robustness *) + | st :: _ -> st + in + let push tag = + let style = match Ppstyle.get_style_format tag with + | None -> empty + | Some st -> st + in + (** Use the merging of the latest tag and the one being currently pushed. + This may be useful if for instance the latest tag changes the background and + the current one the foreground, so that the two effects are additioned. *) + let style = Terminal.merge (peek ()) style in + style_stack := style :: !style_stack; + Terminal.eval style + in + let pop _ = match !style_stack with + | [] -> (** Something went wrong, we fallback *) + Terminal.eval default_tag + | _ :: rem -> style_stack := rem; + Terminal.eval (peek ()) + in + let clear () = style_stack := [] in + push, pop, clear + +let init_color_output () = + let push_tag, pop_tag, clear_tag = make_style_stack () in + std_logger_cleanup := clear_tag; + std_logger_tag := Some Ppstyle.to_format; + let tag_handler = { + Format.mark_open_tag = push_tag; + Format.mark_close_tag = pop_tag; + Format.print_open_tag = ignore; + Format.print_close_tag = ignore; + } in + Format.pp_set_mark_tags !std_ft true; + Format.pp_set_mark_tags !err_ft true; + Format.pp_set_formatter_tag_functions !std_ft tag_handler; + Format.pp_set_formatter_tag_functions !err_ft tag_handler + +(* Rules for emacs: + - Debug/info: emacs_quote_info + - Warning/Error: emacs_quote_err + - Notice: unquoted + *) +let emacs_logger = gen_logger emacs_quote_info emacs_quote_err + +(* Output to file, used only in extraction so a candidate for removal *) +let ft_logger old_logger ft ?loc level mesg = + let id x = x in + match level with + | Debug -> msgnl_with ft (make_body id dbg_str mesg) + | Info -> msgnl_with ft (make_body id info_str mesg) + | Notice -> msgnl_with ft mesg + | Warning -> old_logger ?loc level mesg + | Error -> old_logger ?loc level mesg + +let with_output_to_file fname func input = + (* XXX FIXME: redirect std_ft *) + (* let old_logger = !logger in *) + let channel = open_out (String.concat "." [fname; "out"]) in + (* logger := ft_logger old_logger (Format.formatter_of_out_channel channel); *) + try + let output = func input in + (* logger := old_logger; *) + close_out channel; + output + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + (* logger := old_logger; *) + close_out channel; + Exninfo.iraise reraise diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli new file mode 100644 index 000000000..38a400cfd --- /dev/null +++ b/vernac/topfmt.mli @@ -0,0 +1,49 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* pp_global_params -> unit +val set_dflt_gp : Format.formatter -> unit +val get_gp : Format.formatter -> pp_global_params + +(** {6 Output functions of pretty-printing. } *) + +val with_output_to : out_channel -> Format.formatter + +val std_ft : Format.formatter ref +val err_ft : Format.formatter ref +val deep_ft : Format.formatter ref + +(** {6 For parametrization through vernacular. } *) + +val set_depth_boxes : int option -> unit +val get_depth_boxes : unit -> int option + +val set_margin : int option -> unit +val get_margin : unit -> int option + +(** Console display of feedback *) +val std_logger : ?loc:Loc.t -> Feedback.level -> Pp.std_ppcmds -> unit + +val emacs_logger : ?loc:Loc.t -> Feedback.level -> Pp.std_ppcmds -> unit + +val init_color_output : unit -> unit + +(** [with_output_to_file file f x] executes [f x] with logging + redirected to a file [file] *) +val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b + diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 94ef54f70..283c095eb 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -14,4 +14,5 @@ Record Assumptions Vernacinterp Mltop +Topfmt Vernacentries diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 3afe04b37..09c43f93e 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -1448,8 +1448,8 @@ let _ = optdepr = false; optname = "the printing depth"; optkey = ["Printing";"Depth"]; - optread = Pp_control.get_depth_boxes; - optwrite = Pp_control.set_depth_boxes } + optread = Topfmt.get_depth_boxes; + optwrite = Topfmt.set_depth_boxes } let _ = declare_int_option @@ -1457,8 +1457,8 @@ let _ = optdepr = false; optname = "the printing width"; optkey = ["Printing";"Width"]; - optread = Pp_control.get_margin; - optwrite = Pp_control.set_margin } + optread = Topfmt.get_margin; + optwrite = Topfmt.set_margin } let _ = declare_bool_option @@ -2193,7 +2193,7 @@ let with_fail b f = | e -> let e = CErrors.push e in raise (HasFailed (CErrors.iprint - (ExplainErr.process_vernac_interp_error ~allow_uncaught:false ~with_header:false e)))) + (ExplainErr.process_vernac_interp_error ~allow_uncaught:false e)))) () with e when CErrors.noncritical e -> let (e, _) = CErrors.push e in @@ -2226,7 +2226,7 @@ let interp ?(verbosely=true) ?proof (loc,c) = current_timeout := Some n; aux ?locality ?polymorphism isprogcmd v | VernacRedirect (s, (_,v)) -> - Feedback.with_output_to_file s (aux false) v + Topfmt.with_output_to_file s (aux false) v | VernacTime (_,v) -> System.with_time !Flags.time (aux ?locality ?polymorphism isprogcmd) v; -- cgit v1.2.3 From 3fc02bb2034a648c9c27b76a9e7b4e02a78e55b9 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 5 Dec 2016 17:56:22 +0100 Subject: [pp] Move terminal-specific tagging to the toplevel. Previously, tags were associated to terminal styles, which doesn't make sense on terminal-free pretty printing scenarios. This commit moves tag interpretation to the toplevel terminal handling module `Topfmt`. --- ide/richpp.mli | 2 +- lib/clib.mllib | 1 - lib/pp.ml | 1 - lib/pp.mli | 3 +- lib/ppstyle.ml | 66 ------------------------------------------ lib/ppstyle.mli | 50 -------------------------------- plugins/ltac/pptactic.ml | 13 ++------- printing/ppconstr.ml | 32 +++++---------------- printing/printmod.ml | 10 +++---- toplevel/coqloop.ml | 2 +- toplevel/coqtop.ml | 17 +++++------ vernac/topfmt.ml | 74 +++++++++++++++++++++++++++++++++++++++--------- vernac/topfmt.mli | 6 ++++ 13 files changed, 90 insertions(+), 187 deletions(-) delete mode 100644 lib/ppstyle.ml delete mode 100644 lib/ppstyle.mli (limited to 'plugins') diff --git a/ide/richpp.mli b/ide/richpp.mli index 0fe4315b7..ea4b189ba 100644 --- a/ide/richpp.mli +++ b/ide/richpp.mli @@ -19,7 +19,7 @@ type 'annotation located = { (* XXX: The width parameter should be moved to a `formatter_property` record shared with Topfmt *) -(** [rich_pp width get_annotations ppcmds] returns the interpretation +(** [rich_pp width ppcmds] returns the interpretation of [ppcmds] as a semi-structured document that represents (located) annotations of this string. The [get_annotations] function is used to convert tags into the desired diff --git a/lib/clib.mllib b/lib/clib.mllib index 5a5f6afd3..c73ae9b90 100644 --- a/lib/clib.mllib +++ b/lib/clib.mllib @@ -28,7 +28,6 @@ Util Stateid Pp Feedback -Ppstyle CUnix Envars Aux_file diff --git a/lib/pp.ml b/lib/pp.ml index 53c1fb4c3..7b21f9bbd 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -288,4 +288,3 @@ let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v let prvect elem v = prvect_with_sep mt elem v let surround p = hov 1 (str"(" ++ p ++ str")") - diff --git a/lib/pp.mli b/lib/pp.mli index ff4206534..2c45ce0a7 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -160,12 +160,11 @@ val surround : std_ppcmds -> std_ppcmds (** Surround with parenthesis. *) val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds - val pr_loc : Loc.t -> std_ppcmds (** {6 Main renderers, to formatter and to string } *) -(** [msg_with fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) +(** [pp_with fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) val pp_with : Format.formatter -> std_ppcmds -> unit val string_of_ppcmds : std_ppcmds -> string diff --git a/lib/ppstyle.ml b/lib/ppstyle.ml deleted file mode 100644 index 6969c3d5c..000000000 --- a/lib/ppstyle.ml +++ /dev/null @@ -1,66 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* assert false - -let set_style tag st = - try tags := String.Map.update tag st !tags - with Not_found -> assert false - -let clear_styles () = - tags := String.Map.map (fun _ -> None) !tags - -let dump () = String.Map.bindings !tags - -let parse_config s = - let styles = Terminal.parse s in - let set accu (name, st) = - try String.Map.update name (Some st) accu with Not_found -> accu - in - tags := List.fold_left set !tags styles - -(** Default tag is to reset everything *) -let default = Terminal.({ - fg_color = Some `DEFAULT; - bg_color = Some `DEFAULT; - bold = Some false; - italic = Some false; - underline = Some false; - negative = Some false; -}) - -let empty = Terminal.make () - -let error_tag = - let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`RED () in - make ~style ["message"; "error"] - -let warning_tag = - let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`YELLOW () in - make ~style ["message"; "warning"] - -let debug_tag = - let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`MAGENTA () in - make ~style ["message"; "debug"] diff --git a/lib/ppstyle.mli b/lib/ppstyle.mli deleted file mode 100644 index 2690d3910..000000000 --- a/lib/ppstyle.mli +++ /dev/null @@ -1,50 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* string list -> t -(** Create a new tag with the given name. Each name must be unique. The optional - style is taken as the default one. *) - -(** {5 Manipulating global styles} *) - -val get_style : t -> Terminal.style option -(** Get the style associated to a tag from a format tag. *) - -val set_style : t -> Terminal.style option -> unit -(** Set a style associated to a tag. *) - -val clear_styles : unit -> unit -(** Clear all styles. *) - -val parse_config : string -> unit -(** Add all styles from the given string as parsed by {!Terminal.parse}. - Unregistered tags are ignored. *) - -val dump : unit -> (t * Terminal.style option) list -(** Recover the list of known tags together with their current style. *) - -(** {5 Tags} *) - -val error_tag : t -(** Tag used by the {!Pp.msg_error} function. *) - -val warning_tag : t -(** Tag used by the {!Pp.msg_warning} function. *) - -val debug_tag : t -(** Tag used by the {!Pp.msg_debug} function. *) diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index d9410a088..dc418d530 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -29,17 +29,10 @@ open Printer module Tag = struct - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["tactic"; "keyword"] - let primitive = - let style = Terminal.make ~fg_color:`LIGHT_GREEN () in - Ppstyle.make ~style ["tactic"; "primitive"] - - let string = - let style = Terminal.make ~fg_color:`LIGHT_RED () in - Ppstyle.make ~style ["tactic"; "string"] + let keyword = "tactic.keyword" + let primitive = "tactic.primitive" + let string = "tactic.string" end diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index c772f7be1..d92d83275 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -23,32 +23,14 @@ open Misctypes module Tag = struct - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["constr"; "keyword"] + let keyword = "constr.keyword" + let evar = "constr.evar" + let univ = "constr.type" + let notation = "constr.notation" + let variable = "constr.variable" + let reference = "constr.reference" + let path = "constr.path" - let evar = - let style = Terminal.make ~fg_color:`LIGHT_BLUE () in - Ppstyle.make ~style ["constr"; "evar"] - - let univ = - let style = Terminal.make ~bold:true ~fg_color:`YELLOW () in - Ppstyle.make ~style ["constr"; "type"] - - let notation = - let style = Terminal.make ~fg_color:`WHITE () in - Ppstyle.make ~style ["constr"; "notation"] - - let variable = - Ppstyle.make ["constr"; "variable"] - - let reference = - let style = Terminal.make ~fg_color:`LIGHT_GREEN () in - Ppstyle.make ~style ["constr"; "reference"] - - let path = - let style = Terminal.make ~fg_color:`LIGHT_MAGENTA () in - Ppstyle.make ~style ["constr"; "path"] end let do_not_tag _ x = x diff --git a/printing/printmod.ml b/printing/printmod.ml index 521b4ec2a..baa1b8d79 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -28,12 +28,10 @@ open Goptions module Tag = struct - let definition = - let style = Terminal.make ~bold:true ~fg_color:`LIGHT_RED () in - Ppstyle.make ~style ["module"; "definition"] - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["module"; "keyword"] + + let definition = "module.definition" + let keyword = "module.keyword" + end let tag t s = Pp.tag t s diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 43807c1ca..0cc6ca317 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -252,7 +252,7 @@ let print_toplevel_error (e, info) = else mt () else print_location_in_file loc in - let hdr msg = hov 0 (tag Ppstyle.error_tag (str "Error:") ++ spc () ++ msg) in + let hdr msg = hov 0 (Topfmt.err_hdr ++ msg) in locmsg ++ hdr (CErrors.iprint (e, info)) (* Read the input stream until a dot is encountered *) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 268d40c91..c4d8dfec9 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -67,8 +67,8 @@ let init_color () = () | Some s -> (** Overwrite all colors *) - Ppstyle.clear_styles (); - Ppstyle.parse_config s; + Topfmt.clear_styles (); + Topfmt.parse_color_config s; Topfmt.init_color_output () end @@ -308,19 +308,16 @@ let usage () = let print_style_tags () = let () = init_color () in - let tags = Ppstyle.dump () in + let tags = Topfmt.dump_tags () in let iter (t, st) = - let st = match st with Some st -> st | None -> Terminal.make () in - let opt = Terminal.eval st ^ t ^ Terminal.reset ^ "\n" in + let opt = Terminal.eval st ^ t ^ Terminal.reset ^ "\n" in print_string opt in - let make (t, st) = match st with - | None -> None - | Some st -> + let make (t, st) = let tags = List.map string_of_int (Terminal.repr st) in - Some (t ^ "=" ^ String.concat ";" tags) + (t ^ "=" ^ String.concat ";" tags) in - let repr = List.map_filter make tags in + let repr = List.map make tags in let () = Printf.printf "COQ_COLORS=\"%s\"\n" (String.concat ":" repr) in let () = List.iter iter tags in flush_all () diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index e5063e27b..f843484f7 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -97,6 +97,15 @@ let set_margin v = (** Console display of feedback *) +(** Default tags *) +module Tag = struct + + let error = "message.error" + let warning = "message.warning" + let debug = "message.debug" + +end + type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit let msgnl_with fmt strm = @@ -123,10 +132,10 @@ end open Emacs -let dbg_str = tag Ppstyle.debug_tag (str "Debug:") ++ spc () -let info_str = mt () -let warn_str = tag Ppstyle.warning_tag (str "Warning:") ++ spc () -let err_str = tag Ppstyle.error_tag (str "Error:") ++ spc () +let dbg_hdr = tag Tag.debug (str "Debug:") ++ spc () +let info_hdr = mt () +let warn_hdr = tag Tag.warning (str "Warning:") ++ spc () +let err_hdr = tag Tag.error (str "Error:") ++ spc () let make_body quoter info ?loc s = let loc = Option.cata Pp.pr_loc (Pp.mt ()) loc in @@ -134,13 +143,13 @@ let make_body quoter info ?loc s = (* Generic logger *) let gen_logger dbg err ?loc level msg = match level with - | Debug -> msgnl_with !std_ft (make_body dbg dbg_str ?loc msg) - | Info -> msgnl_with !std_ft (make_body dbg info_str ?loc msg) + | Debug -> msgnl_with !std_ft (make_body dbg dbg_hdr ?loc msg) + | Info -> msgnl_with !std_ft (make_body dbg info_hdr ?loc msg) (* XXX: What to do with loc here? *) | Notice -> msgnl_with !std_ft msg | Warning -> Flags.if_warn (fun () -> - msgnl_with !err_ft (make_body err warn_str ?loc msg)) () - | Error -> msgnl_with !err_ft (make_body err err_str ?loc msg) + msgnl_with !err_ft (make_body err warn_hdr ?loc msg)) () + | Error -> msgnl_with !err_ft (make_body err err_hdr ?loc msg) (** Standard loggers *) @@ -153,7 +162,43 @@ let std_logger ?loc level msg = gen_logger (fun x -> x) (fun x -> x) ?loc level msg; !std_logger_cleanup () -(** Color logging. Moved from pp_style, it may need some more refactoring *) +(** Color logging. Moved from Ppstyle, it may need some more refactoring *) + +(* Tag map for terminal style *) +let default_tag_map () = let open Terminal in [ + (* Local to console toplevel *) + "message.error" , make ~bold:true ~fg_color:`WHITE ~bg_color:`RED () + ; "message.warning" , make ~bold:true ~fg_color:`WHITE ~bg_color:`YELLOW () + ; "message.debug" , make ~bold:true ~fg_color:`WHITE ~bg_color:`MAGENTA () + (* Coming from the printer *) + ; "constr.evar" , make ~fg_color:`LIGHT_BLUE () + ; "constr.keyword" , make ~bold:true () + ; "constr.type" , make ~bold:true ~fg_color:`YELLOW () + ; "constr.notation" , make ~fg_color:`WHITE () + (* ["constr"; "variable"] is not assigned *) + ; "constr.reference" , make ~fg_color:`LIGHT_GREEN () + ; "constr.path" , make ~fg_color:`LIGHT_MAGENTA () + ; "module.definition", make ~bold:true ~fg_color:`LIGHT_RED () + ; "module.keyword" , make ~bold:true () + ; "tactic.keyword" , make ~bold:true () + ; "tactic.primitive" , make ~fg_color:`LIGHT_GREEN () + ; "tactic.string" , make ~fg_color:`LIGHT_RED () + ] + +let tag_map = ref CString.Map.empty + +let init_tag_map styles = + let set accu (name, st) = CString.Map.add name st accu in + tag_map := List.fold_left set !tag_map styles + +let clear_styles () = + tag_map := CString.Map.empty + +let parse_color_config file = + let styles = Terminal.parse file in + init_tag_map styles + +let dump_tags () = CString.Map.bindings !tag_map (** Not thread-safe. We should put a lock somewhere if we print from different threads. Do we? *) @@ -175,9 +220,9 @@ let make_style_stack () = | st :: _ -> st in let push tag = - let style = match Ppstyle.get_style tag with - | None -> empty - | Some st -> st + let style = + try CString.Map.find tag !tag_map + with | Not_found -> empty in (** Use the merging of the latest tag and the one being currently pushed. This may be useful if for instance the latest tag changes the background and @@ -196,6 +241,7 @@ let make_style_stack () = push, pop, clear let init_color_output () = + init_tag_map (default_tag_map ()); let push_tag, pop_tag, clear_tag = make_style_stack () in std_logger_cleanup := clear_tag; let tag_handler = { @@ -220,8 +266,8 @@ let emacs_logger = gen_logger emacs_quote_info emacs_quote_err let ft_logger old_logger ft ?loc level mesg = let id x = x in match level with - | Debug -> msgnl_with ft (make_body id dbg_str mesg) - | Info -> msgnl_with ft (make_body id info_str mesg) + | Debug -> msgnl_with ft (make_body id dbg_hdr mesg) + | Info -> msgnl_with ft (make_body id info_hdr mesg) | Notice -> msgnl_with ft mesg | Warning -> old_logger ?loc level mesg | Error -> old_logger ?loc level mesg diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli index 38a400cfd..1555f80a9 100644 --- a/vernac/topfmt.mli +++ b/vernac/topfmt.mli @@ -36,12 +36,18 @@ val get_depth_boxes : unit -> int option val set_margin : int option -> unit val get_margin : unit -> int option +(** Headers for tagging *) +val err_hdr : Pp.std_ppcmds + (** Console display of feedback *) val std_logger : ?loc:Loc.t -> Feedback.level -> Pp.std_ppcmds -> unit val emacs_logger : ?loc:Loc.t -> Feedback.level -> Pp.std_ppcmds -> unit val init_color_output : unit -> unit +val clear_styles : unit -> unit +val parse_color_config : string -> unit +val dump_tags : unit -> (string * Terminal.style) list (** [with_output_to_file file f x] executes [f x] with logging redirected to a file [file] *) -- cgit v1.2.3 From 00b1ceb18db39334a357784a114e45a9012cf594 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 6 Feb 2017 04:52:43 +0100 Subject: [extraction] Flush formatters at end of output. Previous implementations of `Pp` flushed on newline, however, depending on the formatter this may not be always the case. We now alwayas flush the formatters before closing the file as this is the intended behavior. --- plugins/extraction/extract_env.ml | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'plugins') diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index ee623c5ca..2b12462ad 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -519,8 +519,10 @@ let print_structure_to_file (fn,si,mo) dry struc = set_phase Impl; pp_with ft (d.preamble mo comment opened unsafe_needs); pp_with ft (d.pp_struct struc); + Format.pp_print_flush ft (); Option.iter close_out cout; with reraise -> + Format.pp_print_flush ft (); Option.iter close_out cout; raise reraise end; if not dry then Option.iter info_file fn; @@ -533,8 +535,10 @@ let print_structure_to_file (fn,si,mo) dry struc = set_phase Intf; pp_with ft (d.sig_preamble mo comment opened unsafe_needs); pp_with ft (d.pp_sig (signature_of_structure struc)); + Format.pp_print_flush ft (); close_out cout; with reraise -> + Format.pp_print_flush ft (); close_out cout; raise reraise end; info_file si) -- cgit v1.2.3 From 3602b909afc6eac0f150c9961a04b0bf50d8bbf0 Mon Sep 17 00:00:00 2001 From: Tej Chajed Date: Fri, 10 Mar 2017 11:05:27 -0500 Subject: funind: Ignore missing info for current function Fixes [Coq bug #5372](https://coq.inria.fr/bugs/show_bug.cgi?id=5372) "Anomaly: Not a valid information when defining mutual fixpoints that are not mutual with Function". --- plugins/funind/functional_principles_proofs.ml | 3 +-- test-suite/bugs/closed/5372.v | 7 +++++++ 2 files changed, 8 insertions(+), 2 deletions(-) create mode 100644 test-suite/bugs/closed/5372.v (limited to 'plugins') diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index b0ffc775b..0bbe4bb4c 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1215,7 +1215,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let mk_fixes : tactic = let pre_info,infos = list_chop fun_num infos in match pre_info,infos with - | [],[] -> tclIDTAC + | _,[] -> tclIDTAC | _, this_fix_info::others_infos -> let other_fix_infos = List.map @@ -1231,7 +1231,6 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam else Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) other_fix_infos 0) - | _ -> anomaly (Pp.str "Not a valid information") in let first_tac : tactic = (* every operations until fix creations *) tclTHENSEQ diff --git a/test-suite/bugs/closed/5372.v b/test-suite/bugs/closed/5372.v new file mode 100644 index 000000000..2dc78d4c7 --- /dev/null +++ b/test-suite/bugs/closed/5372.v @@ -0,0 +1,7 @@ +(* coq bug 5372: https://coq.inria.fr/bugs/show_bug.cgi?id=5372 *) +Function odd (n:nat) := + match n with + | 0 => false + | S n => true + end +with even (n:nat) := false. -- cgit v1.2.3 From d2061bd8cd2d809d6e5a849dd150e9e0d74331fc Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 16 Dec 2016 17:23:33 +0100 Subject: Remove duplicate lemmas. --- plugins/micromega/RMicromega.v | 315 +++---------------------------------- plugins/micromega/coq_micromega.ml | 3 +- 2 files changed, 26 insertions(+), 292 deletions(-) (limited to 'plugins') diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index 2352d78d6..30e475b71 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -18,7 +18,7 @@ Require Import Refl. Require Import Raxioms RIneq Rpow_def DiscrR. Require Import QArith. Require Import Qfield. - +Require Import Qreals. Require Setoid. (*Declare ML Module "micromega_plugin".*) @@ -38,15 +38,8 @@ Proof. exact Rplus_opp_r. Qed. -Add Ring Rring : Rsrt. Open Scope R_scope. -Lemma Rmult_neutral : forall x:R , 0 * x = 0. -Proof. - intro ; ring. -Qed. - - Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt. Proof. constructor; intros ; subst ; try (intuition (subst; try ring ; auto with real)). @@ -59,142 +52,41 @@ Proof. apply (Rlt_irrefl m) ; auto. apply Rnot_le_lt. auto with real. destruct (total_order_T n m) as [ [H1 | H1] | H1] ; auto. - intros. - rewrite <- (Rmult_neutral m). - apply (Rmult_lt_compat_r) ; auto. -Qed. - -Definition IQR := fun x : Q => (IZR (Qnum x) * / IZR (' Qden x))%R. - - -Lemma Rinv_elim : forall x y z, - y <> 0 -> (z * y = x <-> x * / y = z). -Proof. - intros. - split ; intros. - subst. - rewrite Rmult_assoc. - rewrite Rinv_r; auto. - ring. - subst. - rewrite Rmult_assoc. - rewrite (Rmult_comm (/ y)). - rewrite Rinv_r ; auto. - ring. -Qed. - -Ltac INR_nat_of_P := - match goal with - | H : context[INR (Pos.to_nat ?X)] |- _ => - revert H ; - let HH := fresh in - assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X)) - | |- context[INR (Pos.to_nat ?X)] => - let HH := fresh in - assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X)) - end. - -Ltac add_eq expr val := set (temp := expr) ; - generalize (eq_refl temp) ; - unfold temp at 1 ; generalize temp ; intro val ; clear temp. - -Ltac Rinv_elim := - match goal with - | |- context[?x * / ?y] => - let z := fresh "v" in - add_eq (x * / y) z ; - let H := fresh in intro H ; rewrite <- Rinv_elim in H - end. - -Lemma Rlt_neq : forall r , 0 < r -> r <> 0. -Proof. - red. intros. - subst. - apply (Rlt_irrefl 0 H). + now apply Rmult_lt_0_compat. Qed. +Notation IQR := Q2R (only parsing). Lemma Rinv_1 : forall x, x * / 1 = x. Proof. intro. - Rinv_elim. - subst ; ring. - apply R1_neq_R0. + rewrite Rinv_1. + apply Rmult_1_r. Qed. -Lemma Qeq_true : forall x y, - Qeq_bool x y = true -> - IQR x = IQR y. +Lemma Qeq_true : forall x y, Qeq_bool x y = true -> IQR x = IQR y. Proof. - unfold IQR. - simpl. - intros. - apply Qeq_bool_eq in H. - unfold Qeq in H. - assert (IZR (Qnum x * ' Qden y) = IZR (Qnum y * ' Qden x))%Z. - rewrite H. reflexivity. - repeat rewrite mult_IZR in H0. - simpl in H0. - revert H0. - repeat INR_nat_of_P. intros. - apply Rinv_elim in H2 ; [| apply Rlt_neq ; auto]. - rewrite <- H2. - field. - split ; apply Rlt_neq ; auto. + now apply Qeq_eqR, Qeq_bool_eq. Qed. Lemma Qeq_false : forall x y, Qeq_bool x y = false -> IQR x <> IQR y. Proof. intros. - apply Qeq_bool_neq in H. - intro. apply H. clear H. - unfold Qeq,IQR in *. - simpl in *. - revert H0. - repeat Rinv_elim. - intros. - subst. - assert (IZR (Qnum x * ' Qden y)%Z = IZR (Qnum y * ' Qden x)%Z). - repeat rewrite mult_IZR. - simpl. - rewrite <- H0. rewrite <- H. - ring. - apply eq_IZR ; auto. - INR_nat_of_P; intros; apply Rlt_neq ; auto. - INR_nat_of_P; intros ; apply Rlt_neq ; auto. + apply Qeq_bool_neq in H. + contradict H. + now apply eqR_Qeq. Qed. - - Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> IQR x <= IQR y. Proof. intros. - apply Qle_bool_imp_le in H. - unfold Qle in H. - unfold IQR. - simpl in *. - apply IZR_le in H. - repeat rewrite mult_IZR in H. - simpl in H. - repeat INR_nat_of_P; intros. - assert (Hr := Rlt_neq r H). - assert (Hr0 := Rlt_neq r0 H0). - replace (IZR (Qnum x) * / r) with ((IZR (Qnum x) * r0) * (/r * /r0)). - replace (IZR (Qnum y) * / r0) with ((IZR (Qnum y) * r) * (/r * /r0)). - apply Rmult_le_compat_r ; auto. - apply Rmult_le_pos. - unfold Rle. left. apply Rinv_0_lt_compat ; auto. - unfold Rle. left. apply Rinv_0_lt_compat ; auto. - field ; intuition. - field ; intuition. + now apply Qle_Rle, Qle_bool_imp_le. Qed. - - Lemma IQR_0 : IQR 0 = 0. Proof. - compute. apply Rinv_1. + apply Rmult_0_l. Qed. Lemma IQR_1 : IQR 1 = 1. @@ -202,160 +94,6 @@ Proof. compute. apply Rinv_1. Qed. -Lemma IQR_plus : forall x y, IQR (x + y) = IQR x + IQR y. -Proof. - intros. - unfold IQR. - simpl in *. - rewrite plus_IZR in *. - rewrite mult_IZR in *. - simpl. - rewrite Pos2Nat.inj_mul. - rewrite mult_INR. - rewrite mult_IZR. - simpl. - repeat INR_nat_of_P. - intros. field. - split ; apply Rlt_neq ; auto. -Qed. - -Lemma IQR_opp : forall x, IQR (- x) = - IQR x. -Proof. - intros. - unfold IQR. - simpl. - rewrite opp_IZR. - ring. -Qed. - -Lemma IQR_minus : forall x y, IQR (x - y) = IQR x - IQR y. -Proof. - intros. - unfold Qminus. - rewrite IQR_plus. - rewrite IQR_opp. - ring. -Qed. - - -Lemma IQR_mult : forall x y, IQR (x * y) = IQR x * IQR y. -Proof. - unfold IQR ; intros. - simpl. - repeat rewrite mult_IZR. - rewrite Pos2Nat.inj_mul. - rewrite mult_INR. - repeat INR_nat_of_P. - intros. field ; split ; apply Rlt_neq ; auto. -Qed. - -Lemma IQR_inv_lt : forall x, (0 < x)%Q -> - IQR (/ x) = / IQR x. -Proof. - unfold IQR ; simpl. - intros. - unfold Qlt in H. - revert H. - simpl. - intros. - unfold Qinv. - destruct x. - destruct Qnum ; simpl in *. - exfalso. auto with zarith. - clear H. - repeat INR_nat_of_P. - intros. - assert (HH := Rlt_neq _ H). - assert (HH0 := Rlt_neq _ H0). - rewrite Rinv_mult_distr ; auto. - rewrite Rinv_involutive ; auto. - ring. - apply Rinv_0_lt_compat in H0. - apply Rlt_neq ; auto. - simpl in H. - exfalso. - rewrite Pos.mul_comm in H. - compute in H. - discriminate. -Qed. - -Lemma Qinv_opp : forall x, (- (/ x) = / ( -x))%Q. -Proof. - destruct x ; destruct Qnum ; reflexivity. -Qed. - -Lemma Qopp_involutive_strong : forall x, (- - x = x)%Q. -Proof. - intros. - destruct x. - unfold Qopp. - simpl. - rewrite Z.opp_involutive. - reflexivity. -Qed. - -Lemma Ropp_0 : forall r , - r = 0 -> r = 0. -Proof. - intros. - rewrite <- (Ropp_involutive r). - apply Ropp_eq_0_compat ; auto. -Qed. - -Lemma IQR_x_0 : forall x, IQR x = 0 -> x == 0%Q. -Proof. - destruct x ; simpl. - unfold IQR. - simpl. - INR_nat_of_P. - intros. - apply Rmult_integral in H0. - destruct H0. - apply eq_IZR_R0 in H0. - subst. - reflexivity. - exfalso. - apply Rinv_0_lt_compat in H. - rewrite <- H0 in H. - apply Rlt_irrefl in H. auto. -Qed. - - -Lemma IQR_inv_gt : forall x, (0 > x)%Q -> - IQR (/ x) = / IQR x. -Proof. - intros. - rewrite <- (Qopp_involutive_strong x). - rewrite <- Qinv_opp. - rewrite IQR_opp. - rewrite IQR_inv_lt. - repeat rewrite IQR_opp. - rewrite Ropp_inv_permute. - auto. - intro. - apply Ropp_0 in H0. - apply IQR_x_0 in H0. - rewrite H0 in H. - compute in H. discriminate. - unfold Qlt in *. - destruct x ; simpl in *. - auto with zarith. -Qed. - -Lemma IQR_inv : forall x, ~ x == 0 -> - IQR (/ x) = / IQR x. -Proof. - intros. - assert ( 0 > x \/ 0 < x)%Q. - destruct x ; unfold Qlt, Qeq in * ; simpl in *. - rewrite Z.mul_1_r in *. - destruct Qnum ; simpl in * ; intuition auto. - right. reflexivity. - left ; reflexivity. - destruct H0. - apply IQR_inv_gt ; auto. - apply IQR_inv_lt ; auto. -Qed. - Lemma IQR_inv_ext : forall x, IQR (/ x) = (if Qeq_bool x 0 then 0 else / IQR x). Proof. @@ -366,18 +104,13 @@ Proof. destruct x ; simpl. unfold Qeq in H. simpl in H. - replace Qnum with 0%Z. - compute. rewrite Rinv_1. - reflexivity. - rewrite <- H. ring. + rewrite Zmult_1_r in H. + rewrite H. + apply Rmult_0_l. intros. - apply IQR_inv. - intro. - rewrite <- Qeq_bool_iff in H0. - congruence. + now apply Q2R_inv, Qeq_bool_neq. Qed. - Notation to_nat := N.to_nat. Lemma QSORaddon : @@ -391,10 +124,10 @@ Proof. constructor ; intros ; try reflexivity. apply IQR_0. apply IQR_1. - apply IQR_plus. - apply IQR_minus. - apply IQR_mult. - apply IQR_opp. + apply Q2R_plus. + apply Q2R_minus. + apply Q2R_mult. + apply Q2R_opp. apply Qeq_true ; auto. apply R_power_theory. apply Qeq_false. @@ -453,13 +186,13 @@ Proof. apply IQR_1. reflexivity. unfold IQR. simpl. rewrite Rinv_1. reflexivity. - apply IQR_plus. - apply IQR_minus. - apply IQR_mult. + apply Q2R_plus. + apply Q2R_minus. + apply Q2R_mult. rewrite <- IHc. apply IQR_inv_ext. rewrite <- IHc. - apply IQR_opp. + apply Q2R_opp. Qed. Require Import EnvRing. diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 97f29df82..6051cb3d3 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -364,6 +364,7 @@ struct [["Coq";"Reals" ; "Rdefinitions"]; ["Coq";"Reals" ; "Rpow_def"] ; ["Coq";"Reals" ; "Raxioms"] ; + ["Coq";"QArith"; "Qreals"] ; ] let z_modules = [["Coq";"ZArith";"BinInt"]] @@ -479,7 +480,7 @@ struct let coq_Rinv = lazy (r_constant "Rinv") let coq_Rpower = lazy (r_constant "pow") let coq_IZR = lazy (r_constant "IZR") - let coq_IQR = lazy (constant "IQR") + let coq_IQR = lazy (r_constant "Q2R") let coq_PEX = lazy (constant "PEX" ) -- cgit v1.2.3 From ddbc3839923731686a89a401d0f9dd44f3ad339b Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 1 Feb 2017 14:37:08 +0100 Subject: Fix broken evaluation strategies for ring and field. A bang indicates an argument that must be reduced, a star indicates an argument that must be handled recursively. PEeval: R r0 r1 add mul sub opp C phi Cpow powphi pow varmap pol 0 1 2 3 4 5 6 7 8! 9 10! 11 12* 13! FEeval: R r0 r1 add mul sub opp div inv C phi Cpow powphi pow varmap pol 0 1 2 3 4 5 6 7 8 9 10! 11 12! 13 14* 15! Pphi_dev: R r0 r1 add mul sub opp C c0 c1 ceq phi sign varmap pol 0 1 2 3 4 5 6 7 8! 9! 10! 11! 12! 13* 14! Pphi_pow: R r0 r1 add mul sub opp C c0 c1 ceq phi Cpow powphi pow sign varmap pol 0 1 2 3 4 5 6 7 8! 9! 10! 11! 12 13! 14 15! 16* 17! display_linear: R r0 r1 add mul sub opp div C c0 c1 ceq phi sign varmap num den 0 1 2 3 4 5 6 7 8 9! 10!11! 12! 13! 14* 15! 16! display_pow_linear: R r0 r1 add mul sub opp div C c0 c1 ceq phi Cpow powphi pow sign varmap num den 0 1 2 3 4 5 6 7 8 9! 10!11! 12! 13 14! 15 16! 17* 18! 19! PCond: R r0 r1 add mul sub opp eq C phi Cpow powphi pow varmap pol 0 1 2 3 4 5 6 7 8 9! 10 11! 12 13* 14! --- plugins/setoid_ring/newring.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) (limited to 'plugins') diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index eb35d3f80..2a3d66934 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -330,7 +330,7 @@ let _ = add_map "ring" (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) - pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)]) + pol_cst "PEeval", (function -1|8|10|13->Eval|12->Rec|_->Prot)]) (****************************************************************************) (* Ring database *) @@ -761,7 +761,7 @@ let _ = add_map "field" my_reference "display_linear", (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot); my_reference "display_pow_linear", - (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot); + (function -1|9|10|11|12|14|16|18|19->Eval|17->Rec|_->Prot); (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); @@ -769,10 +769,10 @@ let _ = add_map "field" (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) - pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot); + pol_cst "PEeval", (function -1|8|10|13->Eval|12->Rec|_->Prot); (* FEeval: evaluate morphism, protect field operations and make recursive call on the var map *) - my_reference "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);; + my_reference "FEeval", (function -1|10|12|15->Eval|14->Rec|_->Prot)]);; let _ = add_map "field_cond" (map_without_eq @@ -781,7 +781,6 @@ let _ = add_map "field_cond" (* PCond: evaluate morphism and denum list, protect ring operations and make recursive call on the var map *) my_reference "PCond", (function -1|9|11|14->Eval|13->Rec|_->Prot)]);; -(* (function -1|9|11->Eval|10->Rec|_->Prot)]);;*) let _ = Redexpr.declare_reduction "simpl_field_expr" -- cgit v1.2.3 From e1ef9491edaf8f7e6f553c49b24163b7e2a53825 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sun, 5 Mar 2017 21:03:51 +0100 Subject: Change the parser and printer so that they use IZR for real constants. There are two main issues. First, (-cst)%R is no longer syntactically equal to (-(cst))%R (though they are still convertible). This breaks some rewriting rules. Second, the ring/field_simplify tactics did not know how to refold real constants. This defect is no longer hidden by the pretty-printer, which makes these tactics almost unusable on goals containing large constants. This commit also modifies the ring/field tactics so that real constant reification is now constant time rather than linear. Note that there is now a bit of code duplication between z_syntax and r_syntax. This should be fixed once plugin interdependencies are supported. Ideally the r_syntax plugin should just disappear by declaring IZR as a coercion. Unfortunately the coercion mechanism is not powerful enough yet, be it for parsing (need the ability for a scope to delegate constant parsing to another scope) or printing (too many visible coercions left). --- plugins/fourier/Fourier.v | 2 +- plugins/setoid_ring/RealField.v | 21 ++++-- plugins/syntax/r_syntax.ml | 159 +++++++++++++++++++++------------------- theories/Reals/Alembert.v | 2 +- theories/Reals/ArithProp.v | 6 +- theories/Reals/DiscrR.v | 9 --- theories/Reals/Exp_prop.v | 12 +-- theories/Reals/Machin.v | 2 +- theories/Reals/RIneq.v | 2 +- theories/Reals/R_Ifp.v | 39 ++++------ theories/Reals/R_sqrt.v | 4 +- theories/Reals/Ranalysis2.v | 16 ++-- theories/Reals/Ranalysis3.v | 32 +++----- theories/Reals/Ranalysis5.v | 5 +- theories/Reals/Ratan.v | 44 ++++------- theories/Reals/Raxioms.v | 29 -------- theories/Reals/Rbasic_fun.v | 18 ++--- theories/Reals/Rdefinitions.v | 29 ++++++++ theories/Reals/Rfunctions.v | 5 +- theories/Reals/Rlogic.v | 2 +- theories/Reals/Rpow_def.v | 2 +- theories/Reals/Rpower.v | 9 +-- theories/Reals/Rseries.v | 2 +- theories/Reals/Rtrigo1.v | 42 +++++------ theories/Reals/Rtrigo_alt.v | 6 +- theories/Reals/Rtrigo_reg.v | 3 +- theories/Reals/Sqrt_reg.v | 1 + 27 files changed, 229 insertions(+), 274 deletions(-) (limited to 'plugins') diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v index 1d7ee93ea..a96254713 100644 --- a/plugins/fourier/Fourier.v +++ b/plugins/fourier/Fourier.v @@ -13,6 +13,6 @@ Require Export DiscrR. Require Export Fourier_util. Declare ML Module "fourier_plugin". -Ltac fourier := abstract (fourierz; field; discrR). +Ltac fourier := abstract (compute [IZR IPR IPR_2] in *; fourierz; field; discrR). Ltac fourier_eq := apply Rge_antisym; fourier. diff --git a/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v index 293722125..facd2e062 100644 --- a/plugins/setoid_ring/RealField.v +++ b/plugins/setoid_ring/RealField.v @@ -59,11 +59,12 @@ Notation Rset := (Eqsth R). Notation Rext := (Eq_ext Rplus Rmult Ropp). Lemma Rlt_0_2 : 0 < 2. +Proof. apply Rlt_trans with (0 + 1). apply Rlt_n_Sn. rewrite Rplus_comm. apply Rplus_lt_compat_l. - replace 1 with (0 + 1). + replace R1 with (0 + 1). apply Rlt_n_Sn. apply Rplus_0_l. Qed. @@ -126,9 +127,17 @@ Ltac Rpow_tac t := | _ => constr:(N.of_nat t) end. -Add Field RField : Rfield - (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]). - - - +Ltac IZR_tac t := + match t with + | R0 => constr:(0%Z) + | R1 => constr:(1%Z) + | IZR ?u => + match isZcst u with + | true => u + | _ => constr:(InitialRing.NotConstant) + end + | _ => constr:(InitialRing.NotConstant) + end. +Add Field RField : Rfield + (completeness Zeq_bool_complete, constants [IZR_tac], power_tac R_power_theory [Rpow_tac]). diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 3ae2d45f3..8f065f528 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -9,6 +9,8 @@ open Util open Names open Globnames +open Glob_term +open Bigint (* Poor's man DECLARE PLUGIN *) let __coq_plugin_name = "r_syntax_plugin" @@ -17,95 +19,105 @@ let () = Mltop.add_known_module __coq_plugin_name exception Non_closed_number (**********************************************************************) -(* Parsing R via scopes *) +(* Parsing positive via scopes *) (**********************************************************************) -open Glob_term -open Bigint +let binnums = ["Coq";"Numbers";"BinNums"] let make_dir l = DirPath.make (List.rev_map Id.of_string l) -let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"] -let make_path dir id = Libnames.make_path dir (Id.of_string id) +let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) + +let positive_path = make_path binnums "positive" + +(* TODO: temporary hack *) +let make_kn dir id = Globnames.encode_mind dir id + +let positive_kn = make_kn (make_dir binnums) (Id.of_string "positive") +let glob_positive = IndRef (positive_kn,0) +let path_of_xI = ((positive_kn,0),1) +let path_of_xO = ((positive_kn,0),2) +let path_of_xH = ((positive_kn,0),3) +let glob_xI = ConstructRef path_of_xI +let glob_xO = ConstructRef path_of_xO +let glob_xH = ConstructRef path_of_xH + +let pos_of_bignat dloc x = + let ref_xI = GRef (dloc, glob_xI, None) in + let ref_xH = GRef (dloc, glob_xH, None) in + let ref_xO = GRef (dloc, glob_xO, None) in + let rec pos_of x = + match div2_with_rest x with + | (q,false) -> GApp (dloc, ref_xO,[pos_of q]) + | (q,true) when not (Bigint.equal q zero) -> GApp (dloc,ref_xI,[pos_of q]) + | (q,true) -> ref_xH + in + pos_of x + +(**********************************************************************) +(* Printing positive via scopes *) +(**********************************************************************) + +let rec bignat_of_pos = function + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) + | GRef (_, a, _) when Globnames.eq_gr a glob_xH -> Bigint.one + | _ -> raise Non_closed_number + +(**********************************************************************) +(* Parsing Z via scopes *) +(**********************************************************************) +let z_path = make_path binnums "Z" +let z_kn = make_kn (make_dir binnums) (Id.of_string "Z") +let glob_z = IndRef (z_kn,0) +let path_of_ZERO = ((z_kn,0),1) +let path_of_POS = ((z_kn,0),2) +let path_of_NEG = ((z_kn,0),3) +let glob_ZERO = ConstructRef path_of_ZERO +let glob_POS = ConstructRef path_of_POS +let glob_NEG = ConstructRef path_of_NEG + +let z_of_int dloc n = + if not (Bigint.equal n zero) then + let sgn, n = + if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in + GApp(dloc, GRef (dloc,sgn,None), [pos_of_bignat dloc n]) + else + GRef (dloc, glob_ZERO, None) + +(**********************************************************************) +(* Printing Z via scopes *) +(**********************************************************************) + +let bigint_of_z = function + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) + | GRef (_, a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero + | _ -> raise Non_closed_number + +(**********************************************************************) +(* Parsing R via scopes *) +(**********************************************************************) + +let rdefinitions = ["Coq";"Reals";"Rdefinitions"] let r_path = make_path rdefinitions "R" (* TODO: temporary hack *) let make_path dir id = Globnames.encode_con dir (Id.of_string id) -let r_kn = make_path rdefinitions "R" -let glob_R = ConstRef r_kn -let glob_R1 = ConstRef (make_path rdefinitions "R1") -let glob_R0 = ConstRef (make_path rdefinitions "R0") -let glob_Ropp = ConstRef (make_path rdefinitions "Ropp") -let glob_Rplus = ConstRef (make_path rdefinitions "Rplus") -let glob_Rmult = ConstRef (make_path rdefinitions "Rmult") - -let two = mult_2 one -let three = add_1 two -let four = mult_2 two - -(* Unary representation of strictly positive numbers *) -let rec small_r dloc n = - if equal one n then GRef (dloc, glob_R1, None) - else GApp(dloc,GRef (dloc,glob_Rplus, None), - [GRef (dloc, glob_R1, None);small_r dloc (sub_1 n)]) - -let r_of_posint dloc n = - let r1 = GRef (dloc, glob_R1, None) in - let r2 = small_r dloc two in - let rec r_of_pos n = - if less_than n four then small_r dloc n - else - let (q,r) = div2_with_rest n in - let b = GApp(dloc,GRef(dloc,glob_Rmult,None),[r2;r_of_pos q]) in - if r then GApp(dloc,GRef(dloc,glob_Rplus,None),[r1;b]) else b in - if not (Bigint.equal n zero) then r_of_pos n else GRef(dloc,glob_R0,None) +let glob_IZR = ConstRef (make_path (make_dir rdefinitions) "IZR") let r_of_int dloc z = - if is_strictly_neg z then - GApp (dloc, GRef(dloc,glob_Ropp,None), [r_of_posint dloc (neg z)]) - else - r_of_posint dloc z + GApp (dloc, GRef(dloc,glob_IZR,None), [z_of_int dloc z]) (**********************************************************************) (* Printing R via scopes *) (**********************************************************************) -let bignat_of_r = -(* for numbers > 1 *) -let rec bignat_of_pos = function - (* 1+1 *) - | GApp (_,GRef (_,p,_), [GRef (_,o1,_); GRef (_,o2,_)]) - when Globnames.eq_gr p glob_Rplus && Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 -> two - (* 1+(1+1) *) - | GApp (_,GRef (_,p1,_), [GRef (_,o1,_); - GApp(_,GRef (_,p2,_),[GRef(_,o2,_);GRef(_,o3,_)])]) - when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rplus && - Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 && Globnames.eq_gr o3 glob_R1 -> three - (* (1+1)*b *) - | GApp (_,GRef (_,p,_), [a; b]) when Globnames.eq_gr p glob_Rmult -> - if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number; - mult_2 (bignat_of_pos b) - (* 1+(1+1)*b *) - | GApp (_,GRef (_,p1,_), [GRef (_,o,_); GApp (_,GRef (_,p2,_),[a;b])]) - when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rmult && Globnames.eq_gr o glob_R1 -> - if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number; - add_1 (mult_2 (bignat_of_pos b)) - | _ -> raise Non_closed_number -in -let bignat_of_r = function - | GRef (_,a,_) when Globnames.eq_gr a glob_R0 -> zero - | GRef (_,a,_) when Globnames.eq_gr a glob_R1 -> one - | r -> bignat_of_pos r -in -bignat_of_r - let bigint_of_r = function - | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_Ropp -> - let n = bignat_of_r a in - if Bigint.equal n zero then raise Non_closed_number; - neg n - | a -> bignat_of_r a + | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_IZR -> + bigint_of_z a + | _ -> raise Non_closed_number let uninterp_r p = try @@ -113,12 +125,9 @@ let uninterp_r p = with Non_closed_number -> None -let mkGRef gr = GRef (Loc.ghost,gr,None) - let _ = Notation.declare_numeral_interpreter "R_scope" (r_path,["Coq";"Reals";"Rdefinitions"]) r_of_int - (List.map mkGRef - [glob_Ropp;glob_R0;glob_Rplus;glob_Rmult;glob_R1], + ([GRef (Loc.ghost,glob_IZR,None)], uninterp_r, false) diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v index a98d529fa..0e1608a32 100644 --- a/theories/Reals/Alembert.v +++ b/theories/Reals/Alembert.v @@ -78,7 +78,7 @@ Proof. ring. discrR. discrR. - pattern 1 at 3; replace 1 with (/ 1); + replace 1 with (/ 1); [ apply tech7; discrR | apply Rinv_1 ]. replace (An (S x)) with (An (S x + 0)%nat). apply (tech6 (fun i:nat => An (S x + i)%nat) (/ 2)). diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v index 7d9fff276..67584f775 100644 --- a/theories/Reals/ArithProp.v +++ b/theories/Reals/ArithProp.v @@ -106,7 +106,7 @@ Proof. split. ring. unfold k0; case (Rcase_abs y) as [Hlt|Hge]. - assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; change (IZR 1) with 1; + assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; simpl; unfold Rminus. replace (- ((1 + - IZR (up (x / - y))) * y)) with ((IZR (up (x / - y)) - 1) * y); [ idtac | ring ]. @@ -140,10 +140,10 @@ Proof. rewrite <- Ropp_mult_distr_r_reverse; rewrite (Ropp_inv_permute _ H); elim H0; unfold Rdiv; intros H1 _; exact H1. apply Ropp_neq_0_compat; assumption. - assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; change (IZR 1) with 1; + assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; simpl; cut (0 < y). intro; unfold Rminus; - replace (- ((IZR (up (x / y)) + -1) * y)) with ((1 - IZR (up (x / y))) * y); + replace (- ((IZR (up (x / y)) + -(1)) * y)) with ((1 - IZR (up (x / y))) * y); [ idtac | ring ]. split. apply Rmult_le_reg_l with (/ y). diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v index 4e2a7c3c6..05911cd53 100644 --- a/theories/Reals/DiscrR.v +++ b/theories/Reals/DiscrR.v @@ -31,9 +31,6 @@ Ltac discrR := try match goal with | |- (?X1 <> ?X2) => - change 2 with (IZR 2); - change 1 with (IZR 1); - change 0 with (IZR 0); repeat rewrite <- plus_IZR || rewrite <- mult_IZR || @@ -52,9 +49,6 @@ Ltac prove_sup0 := end. Ltac omega_sup := - change 2 with (IZR 2); - change 1 with (IZR 1); - change 0 with (IZR 0); repeat rewrite <- plus_IZR || rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; @@ -72,9 +66,6 @@ Ltac prove_sup := end. Ltac Rcompute := - change 2 with (IZR 2); - change 1 with (IZR 1); - change 0 with (IZR 0); repeat rewrite <- plus_IZR || rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v index 569518f7b..e9de24898 100644 --- a/theories/Reals/Exp_prop.v +++ b/theories/Reals/Exp_prop.v @@ -439,20 +439,16 @@ Proof. repeat rewrite <- Rmult_assoc. rewrite <- Rinv_r_sym. rewrite Rmult_1_l. - replace (INR N * INR N) with (Rsqr (INR N)); [ idtac | reflexivity ]. - rewrite Rmult_assoc. - rewrite Rmult_comm. - replace 4 with (Rsqr 2); [ idtac | ring_Rsqr ]. + change 4 with (Rsqr 2). rewrite <- Rsqr_mult. apply Rsqr_incr_1. - replace 2 with (INR 2). - rewrite <- mult_INR; apply H1. - reflexivity. + change 2 with (INR 2). + rewrite Rmult_comm, <- mult_INR; apply H1. left; apply lt_INR_0; apply H. left; apply Rmult_lt_0_compat. - prove_sup0. apply lt_INR_0; apply div2_not_R0. apply lt_n_S; apply H. + now apply IZR_lt. cut (1 < S N)%nat. intro; unfold Rsqr; apply prod_neq_R0; apply not_O_INR; intro; assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4; diff --git a/theories/Reals/Machin.v b/theories/Reals/Machin.v index 19db476fd..2d2385703 100644 --- a/theories/Reals/Machin.v +++ b/theories/Reals/Machin.v @@ -53,7 +53,7 @@ assert (-(PI/4) <= atan x). destruct xm1 as [xm1 | xm1]. rewrite <- atan_1, <- atan_opp; apply Rlt_le, atan_increasing. assumption. - solve[rewrite <- xm1, atan_opp, atan_1; apply Rle_refl]. + solve[rewrite <- xm1; change (-1) with (-(1)); rewrite atan_opp, atan_1; apply Rle_refl]. assert (-(PI/4) < atan y). rewrite <- atan_1, <- atan_opp; apply atan_increasing. assumption. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 686077327..7cd4c00c7 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -1812,7 +1812,7 @@ Qed. (**********) Lemma succ_IZR : forall n:Z, IZR (Z.succ n) = IZR n + 1. Proof. - intro; change 1 with (IZR 1); unfold Z.succ; apply plus_IZR. + intro; unfold Z.succ; apply plus_IZR. Qed. (**********) diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v index d0f9aea28..e9b1762af 100644 --- a/theories/Reals/R_Ifp.v +++ b/theories/Reals/R_Ifp.v @@ -92,7 +92,7 @@ Proof. auto with zarith real. (*inf a 1*) cut (r - IZR (up r) < 0). - rewrite <- Z_R_minus; change (IZR 1) with 1; intro; unfold Rminus; + rewrite <- Z_R_minus; simpl; intro; unfold Rminus; rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; fold (r - IZR (up r)); rewrite Ropp_involutive; elim (Rplus_ne 1); intros a b; pattern 1 at 2; @@ -112,21 +112,12 @@ Lemma base_Int_part : Proof. intro; unfold Int_part; elim (archimed r); intros. split; rewrite <- (Z_R_minus (up r) 1); simpl. - generalize (Rle_minus (IZR (up r) - r) 1 H0); intro; unfold Rminus in H1; - rewrite (Rplus_assoc (IZR (up r)) (- r) (-1)) in H1; - rewrite (Rplus_comm (- r) (-1)) in H1; - rewrite <- (Rplus_assoc (IZR (up r)) (-1) (- r)) in H1; - fold (IZR (up r) - 1) in H1; fold (IZR (up r) - 1 - r) in H1; - apply Rminus_le; auto with zarith real. - generalize (Rplus_gt_compat_l (-1) (IZR (up r)) r H); intro; - rewrite (Rplus_comm (-1) (IZR (up r))) in H1; - generalize (Rplus_gt_compat_l (- r) (IZR (up r) + -1) (-1 + r) H1); - intro; clear H H0 H1; rewrite (Rplus_comm (- r) (IZR (up r) + -1)) in H2; - fold (IZR (up r) - 1) in H2; fold (IZR (up r) - 1 - r) in H2; - rewrite (Rplus_comm (- r) (-1 + r)) in H2; - rewrite (Rplus_assoc (-1) r (- r)) in H2; rewrite (Rplus_opp_r r) in H2; - elim (Rplus_ne (-1)); intros a b; rewrite a in H2; - clear a b; auto with zarith real. + apply Rminus_le. + replace (IZR (up r) - 1 - r) with (IZR (up r) - r - 1) by ring. + now apply Rle_minus. + apply Rminus_gt. + replace (IZR (up r) - 1 - r - -1) with (IZR (up r) - r) by ring. + now apply Rgt_minus. Qed. (**********) @@ -240,7 +231,6 @@ Proof. clear a b; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; cut (1 = IZR 1); auto with zarith real. - intro; rewrite H1 in H; clear H1; rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H; generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H); intros; clear H H0; unfold Int_part at 1; @@ -324,12 +314,12 @@ Proof. rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H0; elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0; clear a b; rewrite <- (Rplus_opp_l 1) in H0; - rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-1) 1) + rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-(1)) 1) in H0; fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H0; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; - cut (1 = IZR 1); auto with zarith real. - intro; rewrite H1 in H; rewrite H1 in H0; clear H1; + auto with zarith real. + change (_ + -1) with (IZR (Int_part r1 - Int_part r2) - 1) in H; rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H; rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H0; rewrite <- (plus_IZR (Int_part r1 - Int_part r2 - 1) 1) in H0; @@ -376,7 +366,7 @@ Proof. rewrite (Ropp_involutive (IZR 1)); rewrite (Ropp_involutive (IZR (Int_part r2))); rewrite (Ropp_plus_distr (IZR (Int_part r1))); - rewrite (Ropp_involutive (IZR (Int_part r2))); change (IZR 1) with 1; + rewrite (Ropp_involutive (IZR (Int_part r2))); simpl; rewrite <- (Rplus_assoc (r1 + - r2) (- IZR (Int_part r1) + IZR (Int_part r2)) 1) ; rewrite (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2))); @@ -442,9 +432,9 @@ Proof. in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0; elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; clear a b; + change 2 with (1 + 1) in H0; rewrite <- (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) 1 1) in H0; - cut (1 = IZR 1); auto with zarith real. - intro; rewrite H1 in H0; rewrite H1 in H; clear H1; + auto with zarith real. rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H; rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0; rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H; @@ -509,7 +499,6 @@ Proof. intros a b; rewrite a in H0; clear a b; elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; clear a b; cut (1 = IZR 1); auto with zarith real. - intro; rewrite H in H1; clear H; rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0; rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1; rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1; @@ -536,7 +525,7 @@ Proof. rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))); unfold Rminus; rewrite - (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-1)) + (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-(1))) ; rewrite <- (Ropp_plus_distr (IZR (Int_part r1) + IZR (Int_part r2)) 1); trivial with zarith real. Qed. diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index 5c975c3f5..0c1e0b7e8 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -420,10 +420,10 @@ Proof. rewrite (Rmult_comm (/ a)). rewrite Rmult_assoc. rewrite <- Rinv_mult_distr. - replace (2 * (2 * a) * a) with (Rsqr (2 * a)). + replace (4 * a * a) with (Rsqr (2 * a)). reflexivity. ring_Rsqr. - rewrite <- Rmult_assoc; apply prod_neq_R0; + apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ]. apply (cond_nonzero a). assumption. diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v index 0254218c4..27cb356a0 100644 --- a/theories/Reals/Ranalysis2.v +++ b/theories/Reals/Ranalysis2.v @@ -88,17 +88,11 @@ Proof. right; unfold Rdiv. repeat rewrite Rabs_mult. rewrite Rabs_Rinv; discrR. - replace (Rabs 8) with 8. - replace 8 with 8; [ idtac | ring ]. - rewrite Rinv_mult_distr; [ idtac | discrR | discrR ]. - replace (2 * / Rabs (f2 x) * (Rabs eps * Rabs (f2 x) * (/ 2 * / 4))) with - (Rabs eps * / 4 * (2 * / 2) * (Rabs (f2 x) * / Rabs (f2 x))); - [ idtac | ring ]. - replace (Rabs eps) with eps. - repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption). - ring. - symmetry ; apply Rabs_right; left; assumption. - symmetry ; apply Rabs_right; left; prove_sup. + rewrite (Rabs_pos_eq 8) by now apply IZR_le. + rewrite (Rabs_pos_eq eps). + field. + now apply Rabs_no_R0. + now apply Rlt_le. Qed. Lemma maj_term2 : diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v index 4e88714d6..d4597aeba 100644 --- a/theories/Reals/Ranalysis3.v +++ b/theories/Reals/Ranalysis3.v @@ -201,8 +201,8 @@ Proof. apply Rabs_pos_lt. unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc. repeat apply prod_neq_R0; try assumption. - red; intro; rewrite H15 in H6; elim (Rlt_irrefl _ H6). - apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption. + now apply Rgt_not_eq. + apply Rinv_neq_0_compat; apply prod_neq_R0; [discrR | assumption]. apply H13. split. apply D_x_no_cond; assumption. @@ -213,8 +213,7 @@ Proof. red; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6). assumption. assumption. - apply Rinv_neq_0_compat; repeat apply prod_neq_R0; - [ discrR | discrR | discrR | assumption ]. + apply Rinv_neq_0_compat; apply prod_neq_R0; [discrR | assumption]. (***********************************) (* Third case *) (* (f1 x)<>0 l1=0 l2=0 *) @@ -224,11 +223,11 @@ Proof. elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))); [ idtac | apply Rabs_pos_lt; unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc; - repeat apply prod_neq_R0; + repeat apply prod_neq_R0 ; [ assumption | assumption - | red; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6) - | apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption ] ]. + | now apply Rgt_not_eq + | apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ]. intros alp_f2d H12. cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)). intro. @@ -295,8 +294,10 @@ Proof. elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))); [ idtac | apply Rabs_pos_lt; unfold Rsqr, Rdiv; - repeat rewrite Rinv_mult_distr; repeat apply prod_neq_R0; - try assumption || discrR ]. + repeat apply prod_neq_R0 ; + [ assumption.. + | now apply Rgt_not_eq + | apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ]. intros alp_f2d H11. assert (H12 := derivable_continuous_pt _ _ X). unfold continuity_pt in H12. @@ -380,15 +381,9 @@ Proof. repeat apply prod_neq_R0; try assumption. red; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6). apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; assumption. apply Rinv_neq_0_compat; assumption. discrR. - discrR. - discrR. - discrR. - discrR. apply prod_neq_R0; [ discrR | assumption ]. elim H13; intros. apply H19. @@ -408,16 +403,9 @@ Proof. repeat apply prod_neq_R0; try assumption. red; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6). apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; assumption. apply Rinv_neq_0_compat; assumption. apply prod_neq_R0; [ discrR | assumption ]. - red; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6). - apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; assumption. (***********************************) (* Fifth case *) (* (f1 x)<>0 l1<>0 l2=0 *) diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v index d172139f5..f9da88aad 100644 --- a/theories/Reals/Ranalysis5.v +++ b/theories/Reals/Ranalysis5.v @@ -249,8 +249,10 @@ assert (Sublemma : forall x y lb ub, lb <= x <= ub /\ lb <= y <= ub -> lb <= (x+ split. replace lb with ((lb + lb) * /2) by field. unfold Rdiv ; apply Rmult_le_compat_r ; intuition. + now apply Rlt_le, Rinv_0_lt_compat, IZR_lt. replace ub with ((ub + ub) * /2) by field. unfold Rdiv ; apply Rmult_le_compat_r ; intuition. + now apply Rlt_le, Rinv_0_lt_compat, IZR_lt. intros x y P N x_lt_y. induction N. simpl ; intuition. @@ -1030,6 +1032,7 @@ intros x ub lb lb_lt_x x_lt_ub. assert (T : 0 < ub - lb). fourier. unfold Rdiv ; apply Rlt_mult_inv_pos ; intuition. +now apply IZR_lt. Qed. Definition mkposreal_lb_ub (x lb ub:R) (lb_lt_x:lb -replace a with ((- IZR 3 ^ 6 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) * - IZR (Z.of_nat (fact 4)) + - IZR 3 ^ 4 * IZR 2 ^ 2 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) * - IZR (Z.of_nat (fact 6)) - - IZR 3 ^ 2 * IZR 2 ^ 4 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 4)) * - IZR (Z.of_nat (fact 6)) + - IZR 2 ^ 6 * IZR (Z.of_nat (fact 2)) * IZR (Z.of_nat (fact 4)) * - IZR (Z.of_nat (fact 6))) / - (IZR 2 ^ 6 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) * - IZR (Z.of_nat (fact 4)) * IZR (Z.of_nat (fact 6))));[ | field; - repeat apply conj;((rewrite <- INR_IZR_INZ; apply INR_fact_neq_0) || - (apply Rgt_not_eq; apply (IZR_lt 0); reflexivity)) ] -end. -rewrite !fact_simpl, !Nat2Z.inj_mul; simpl Z.of_nat. -unfold Rdiv; apply Rmult_lt_0_compat. -unfold Rminus; rewrite !pow_IZR, <- !opp_IZR, <- !mult_IZR, <- !opp_IZR, - <- !plus_IZR; apply (IZR_lt 0); reflexivity. -apply Rinv_0_lt_compat; rewrite !pow_IZR, <- !mult_IZR; apply (IZR_lt 0). -reflexivity. +unfold INR. +simpl. +field_simplify. +change (0 */ 1 < 9925632 / 141557760). +rewrite Rmult_0_l. +apply Rdiv_lt_0_compat ; now apply IZR_lt. Qed. Lemma PI2_1 : 1 < PI/2. @@ -502,11 +482,11 @@ split. rewrite (Rmult_comm (-1)); simpl ((/(Rabs y + 1)) ^ 0). unfold Rdiv; rewrite Rinv_1, !Rmult_assoc, <- !Rmult_plus_distr_l. apply tmp;[assumption | ]. - rewrite Rplus_assoc, Rmult_1_l; pattern 1 at 3; rewrite <- Rplus_0_r. + rewrite Rplus_assoc, Rmult_1_l; pattern 1 at 2; rewrite <- Rplus_0_r. apply Rplus_lt_compat_l. rewrite <- Rmult_assoc. match goal with |- (?a * (-1)) + _ < 0 => - rewrite <- (Rplus_opp_l a), Ropp_mult_distr_r_reverse, Rmult_1_r + rewrite <- (Rplus_opp_l a); change (-1) with (-(1)); rewrite Ropp_mult_distr_r_reverse, Rmult_1_r end. apply Rplus_lt_compat_l. assert (0 < u ^ 2) by (apply pow_lt; assumption). @@ -1078,8 +1058,9 @@ apply Rlt_not_eq; apply Rle_lt_trans with 0;[ | apply Rlt_0_1]. assert (t := pow2_ge_0 x); fourier. replace (1 + x ^ 2) with (1 - - (x ^ 2)) by ring; rewrite <- (tech3 _ n dif). apply sum_eq; unfold tg_alt, Datan_seq; intros i _. -rewrite pow_mult, <- Rpow_mult_distr, Ropp_mult_distr_l_reverse, Rmult_1_l. -reflexivity. +rewrite pow_mult, <- Rpow_mult_distr. +f_equal. +ring. Qed. Lemma Datan_seq_increasing : forall x y n, (n > 0)%nat -> 0 <= x < y -> Datan_seq x n < Datan_seq y n. @@ -1167,6 +1148,7 @@ assert (tool : forall a b, a / b - /b = (-1 + a) /b). reflexivity. set (u := 1 + x ^ 2); rewrite tool; unfold Rminus; rewrite <- Rplus_assoc. unfold Rdiv, u. +change (-1) with (-(1)). rewrite Rplus_opp_l, Rplus_0_l, Ropp_mult_distr_l_reverse, Rabs_Ropp. rewrite Rabs_mult; clear tool u. assert (tool : forall k, Rabs ((-x ^ 2) ^ k) = Rabs ((x ^ 2) ^ k)). diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index e9098104c..7f9db3b18 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -114,35 +114,6 @@ Fixpoint INR (n:nat) : R := Arguments INR n%nat. -(**********************************************************) -(** * Injection from [Z] to [R] *) -(**********************************************************) - -(* compact representation for 2*p *) -Fixpoint IPR_2 (p:positive) : R := - match p with - | xH => 1 + 1 - | xO p => (1 + 1) * IPR_2 p - | xI p => (1 + 1) * (1 + IPR_2 p) - end. - -Definition IPR (p:positive) : R := - match p with - | xH => 1 - | xO p => IPR_2 p - | xI p => 1 + IPR_2 p - end. -Arguments IPR p%positive : simpl never. - -(**********) -Definition IZR (z:Z) : R := - match z with - | Z0 => 0 - | Zpos n => IPR n - | Zneg n => - IPR n - end. -Arguments IZR z%Z : simpl never. - (**********************************************************) (** * [R] Archimedean *) (**********************************************************) diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v index fe5402e6e..df1662497 100644 --- a/theories/Reals/Rbasic_fun.v +++ b/theories/Reals/Rbasic_fun.v @@ -451,20 +451,16 @@ Qed. Lemma Rabs_Ropp : forall x:R, Rabs (- x) = Rabs x. Proof. - intro; cut (- x = -1 * x). - intros; rewrite H. + intro; replace (-x) with (-1 * x) by ring. rewrite Rabs_mult. - cut (Rabs (-1) = 1). - intros; rewrite H0. - ring. + replace (Rabs (-1)) with 1. + apply Rmult_1_l. unfold Rabs; case (Rcase_abs (-1)). intro; ring. - intro H0; generalize (Rge_le (-1) 0 H0); intros. - generalize (Ropp_le_ge_contravar 0 (-1) H1). - rewrite Ropp_involutive; rewrite Ropp_0. - intro; generalize (Rgt_not_le 1 0 Rlt_0_1); intro; generalize (Rge_le 0 1 H2); - intro; exfalso; auto. - ring. + rewrite <- Ropp_0. + intro H0; apply Ropp_ge_cancel in H0. + elim (Rge_not_lt _ _ H0). + apply Rlt_0_1. Qed. (*********) diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index f3f8f7409..cb5dea93a 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -69,3 +69,32 @@ Notation "x <= y <= z" := (x <= y /\ y <= z) : R_scope. Notation "x <= y < z" := (x <= y /\ y < z) : R_scope. Notation "x < y < z" := (x < y /\ y < z) : R_scope. Notation "x < y <= z" := (x < y /\ y <= z) : R_scope. + +(**********************************************************) +(** * Injection from [Z] to [R] *) +(**********************************************************) + +(* compact representation for 2*p *) +Fixpoint IPR_2 (p:positive) : R := + match p with + | xH => R1 + R1 + | xO p => (R1 + R1) * IPR_2 p + | xI p => (R1 + R1) * (R1 + IPR_2 p) + end. + +Definition IPR (p:positive) : R := + match p with + | xH => R1 + | xO p => IPR_2 p + | xI p => R1 + IPR_2 p + end. +Arguments IPR p%positive : simpl never. + +(**********) +Definition IZR (z:Z) : R := + match z with + | Z0 => R0 + | Zpos n => IPR n + | Zneg n => - IPR n + end. +Arguments IZR z%Z : simpl never. diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v index 0a49d4983..99acdd0a1 100644 --- a/theories/Reals/Rfunctions.v +++ b/theories/Reals/Rfunctions.v @@ -416,8 +416,9 @@ Proof. simpl; apply Rabs_R1. replace (S n) with (n + 1)%nat; [ rewrite pow_add | ring ]. rewrite Rabs_mult. - rewrite Hrecn; rewrite Rmult_1_l; simpl; rewrite Rmult_1_r; - rewrite Rabs_Ropp; apply Rabs_R1. + rewrite Hrecn; rewrite Rmult_1_l; simpl; rewrite Rmult_1_r. + change (-1) with (-(1)). + rewrite Rabs_Ropp; apply Rabs_R1. Qed. Lemma pow_mult : forall (x:R) (n1 n2:nat), x ^ (n1 * n2) = (x ^ n1) ^ n2. diff --git a/theories/Reals/Rlogic.v b/theories/Reals/Rlogic.v index 7bd6c916d..b9a9458c8 100644 --- a/theories/Reals/Rlogic.v +++ b/theories/Reals/Rlogic.v @@ -82,7 +82,7 @@ assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R). apply Rle_lt_trans with (1 := H1l). apply archimed. rewrite minus_IZR. - change (IZR 2) with 2%R. + simpl. ring. assert (Hl': (/ (INR (S N) + 1) < l)%R). rewrite <- (Rinv_involutive l) by now apply Rgt_not_eq. diff --git a/theories/Reals/Rpow_def.v b/theories/Reals/Rpow_def.v index 791718a45..f331bb203 100644 --- a/theories/Reals/Rpow_def.v +++ b/theories/Reals/Rpow_def.v @@ -10,6 +10,6 @@ Require Import Rdefinitions. Fixpoint pow (r:R) (n:nat) : R := match n with - | O => R1 + | O => 1 | S n => Rmult r (pow r n) end. diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index a053c349e..f62ed2a6c 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -488,12 +488,9 @@ Proof. rewrite Rinv_r. apply exp_lt_inv. apply Rle_lt_trans with (1 := exp_le_3). - change (3 < 2 ^R 2). + change (3 < 2 ^R (1 + 1)). repeat rewrite Rpower_plus; repeat rewrite Rpower_1. - repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l; - repeat rewrite Rmult_1_l. - pattern 3 at 1; rewrite <- Rplus_0_r; replace (2 + 2) with (3 + 1); - [ apply Rplus_lt_compat_l; apply Rlt_0_1 | ring ]. + now apply (IZR_lt 3 4). prove_sup0. discrR. Qed. @@ -715,7 +712,7 @@ Definition arcsinh x := ln (x + sqrt (x ^ 2 + 1)). Lemma arcsinh_sinh : forall x, arcsinh (sinh x) = x. intros x; unfold sinh, arcsinh. assert (Rminus_eq_0 : forall r, r - r = 0) by (intros; ring). -pattern 1 at 5; rewrite <- exp_0, <- (Rminus_eq_0 x); unfold Rminus. +rewrite <- exp_0, <- (Rminus_eq_0 x); unfold Rminus. rewrite exp_plus. match goal with |- context[sqrt ?a] => replace a with (((exp x + exp(-x))/2)^2) by field diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v index 744fd6641..c6b0c3f37 100644 --- a/theories/Reals/Rseries.v +++ b/theories/Reals/Rseries.v @@ -207,7 +207,7 @@ Section sequence. assert (Rabs (/2) < 1). rewrite Rabs_pos_eq. - rewrite <- Rinv_1 at 3. + rewrite <- Rinv_1. apply Rinv_lt_contravar. rewrite Rmult_1_l. now apply (IZR_lt 0 2). diff --git a/theories/Reals/Rtrigo1.v b/theories/Reals/Rtrigo1.v index 6b1754021..48dbd1944 100644 --- a/theories/Reals/Rtrigo1.v +++ b/theories/Reals/Rtrigo1.v @@ -182,13 +182,11 @@ destruct (pre_cos_bound _ 0 lo up) as [_ upper]. apply Rle_lt_trans with (1 := upper). apply Rlt_le_trans with (2 := lower). unfold cos_approx, sin_approx. -simpl sum_f_R0; change 7 with (IZR 7). -change 8 with (IZR 8). +simpl sum_f_R0. unfold cos_term, sin_term; simpl fact; rewrite !INR_IZR_INZ. -simpl plus; simpl mult. -field_simplify; - try (repeat apply conj; apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity). -unfold Rminus; rewrite !pow_IZR, <- !mult_IZR, <- !opp_IZR, <- ?plus_IZR. +simpl plus; simpl mult; simpl Z_of_nat. +field_simplify. +change (8073344 / 12582912 < 18760 / 24576). match goal with |- IZR ?a / ?b < ?c / ?d => apply Rmult_lt_reg_r with d;[apply (IZR_lt 0); reflexivity | @@ -323,6 +321,7 @@ Lemma sin_PI : sin PI = 0. Proof. assert (H := sin2_cos2 PI). rewrite cos_PI in H. + change (-1) with (-(1)) in H. rewrite <- Rsqr_neg in H. rewrite Rsqr_1 in H. cut (Rsqr (sin PI) = 0). @@ -533,9 +532,8 @@ Qed. Lemma sin_PI_x : forall x:R, sin (PI - x) = sin x. Proof. - intro x; rewrite sin_minus; rewrite sin_PI; rewrite cos_PI; rewrite Rmult_0_l; - unfold Rminus in |- *; rewrite Rplus_0_l; rewrite Ropp_mult_distr_l_reverse; - rewrite Ropp_involutive; apply Rmult_1_l. + intro x; rewrite sin_minus; rewrite sin_PI; rewrite cos_PI. + ring. Qed. Lemma sin_period : forall (x:R) (k:nat), sin (x + 2 * INR k * PI) = sin x. @@ -593,9 +591,9 @@ Proof. generalize (Rsqr_incrst_1 1 (sin x) H (Rlt_le 0 1 Rlt_0_1) (Rlt_le 0 (sin x) (Rlt_trans 0 1 (sin x) Rlt_0_1 H))); - rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0; + rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0. generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0); - repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; + repeat rewrite <- Rplus_assoc; change (-1) with (-(1)); rewrite Rplus_opp_l; rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1; generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1); repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); @@ -603,6 +601,7 @@ Proof. auto with real. cut (sin x < -1). intro; generalize (Ropp_lt_gt_contravar (sin x) (-1) H); + change (-1) with (-(1)); rewrite Ropp_involutive; clear H; intro; generalize (Rsqr_incrst_1 1 (- sin x) H (Rlt_le 0 1 Rlt_0_1) @@ -610,7 +609,7 @@ Proof. rewrite Rsqr_1; intro; rewrite <- Rsqr_neg in H0; rewrite sin2 in H0; unfold Rminus in H0; generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0); - repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; + rewrite <- Rplus_assoc; change (-1) with (-(1)); rewrite Rplus_opp_l; rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1; generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1); repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); @@ -712,17 +711,16 @@ Proof. do 2 rewrite fact_simpl; do 2 rewrite mult_INR. repeat rewrite <- Rmult_assoc. rewrite <- (Rmult_comm (INR (fact (2 * n + 1)))). - rewrite Rmult_assoc. apply Rmult_lt_compat_l. apply lt_INR_0; apply neq_O_lt. assert (H2 := fact_neq_0 (2 * n + 1)). red in |- *; intro; elim H2; symmetry in |- *; assumption. do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; set (x := INR n); unfold INR in |- *. - replace ((2 * x + 1 + 1 + 1) * (2 * x + 1 + 1)) with (4 * x * x + 10 * x + 6); + replace (((1 + 1) * x + 1 + 1 + 1) * ((1 + 1) * x + 1 + 1)) with (4 * x * x + 10 * x + 6); [ idtac | ring ]. - apply Rplus_lt_reg_l with (-4); rewrite Rplus_opp_l; - replace (-4 + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2); + apply Rplus_lt_reg_l with (-(4)); rewrite Rplus_opp_l; + replace (-(4) + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2); [ idtac | ring ]. apply Rplus_le_lt_0_compat. cut (0 <= x). @@ -767,7 +765,7 @@ Proof. unfold Rdiv in |- *; pattern PI at 2 in |- *; rewrite <- Rmult_1_r. apply Rmult_lt_compat_l. apply PI_RGT_0. - pattern 1 at 3 in |- *; rewrite <- Rinv_1; apply Rinv_lt_contravar. + rewrite <- Rinv_1; apply Rinv_lt_contravar. rewrite Rmult_1_l; prove_sup0. pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rlt_0_1. @@ -1715,7 +1713,7 @@ Proof. rewrite H5. rewrite mult_INR. simpl in |- *. - rewrite <- (Rplus_0_l (2 * INR x2 * PI)). + rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)). rewrite sin_period. apply sin_0. rewrite H5. @@ -1725,7 +1723,7 @@ Proof. rewrite Rmult_1_l; rewrite sin_plus. rewrite sin_PI. rewrite Rmult_0_r. - rewrite <- (Rplus_0_l (2 * INR x2 * PI)). + rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)). rewrite sin_period. rewrite sin_0; ring. apply le_IZR. @@ -1747,7 +1745,7 @@ Proof. rewrite H5. rewrite mult_INR. simpl in |- *. - rewrite <- (Rplus_0_l (2 * INR x2 * PI)). + rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)). rewrite sin_period. rewrite sin_0; ring. rewrite H5. @@ -1757,7 +1755,7 @@ Proof. rewrite Rmult_1_l; rewrite sin_plus. rewrite sin_PI. rewrite Rmult_0_r. - rewrite <- (Rplus_0_l (2 * INR x2 * PI)). + rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)). rewrite sin_period. rewrite sin_0; ring. apply le_IZR. @@ -1798,7 +1796,7 @@ Lemma cos_eq_0_0 (x:R) : Proof. rewrite cos_sin. intros Hx. destruct (sin_eq_0_0 (PI/2 + x) Hx) as (k,Hk). clear Hx. - exists (k-1)%Z. rewrite <- Z_R_minus; change (IZR 1) with 1. + exists (k-1)%Z. rewrite <- Z_R_minus; simpl. symmetry in Hk. field_simplify [Hk]. field. Qed. diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v index a5092d22d..092bc30d0 100644 --- a/theories/Reals/Rtrigo_alt.v +++ b/theories/Reals/Rtrigo_alt.v @@ -320,7 +320,7 @@ Proof. (1 - sum_f_R0 (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)). unfold Rminus; rewrite Ropp_plus_distr; rewrite Ropp_involutive; repeat rewrite Rplus_assoc; rewrite (Rplus_comm 1); - rewrite (Rplus_comm (-1)); repeat rewrite Rplus_assoc; + rewrite (Rplus_comm (-(1))); repeat rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; rewrite <- Rabs_Ropp; rewrite Ropp_plus_distr; rewrite Ropp_involutive; unfold Rminus in H6; apply H6. @@ -367,10 +367,10 @@ Proof. reflexivity. ring. intro; elim H2; intros; split. - apply Rplus_le_reg_l with (-1). + apply Rplus_le_reg_l with (-(1)). rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite (Rplus_comm (-1)); apply H3. - apply Rplus_le_reg_l with (-1). + apply Rplus_le_reg_l with (-(1)). rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite (Rplus_comm (-1)); apply H4. unfold cos_term; simpl; unfold Rdiv; rewrite Rinv_1; diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v index 4a1e3179c..d9c18d358 100644 --- a/theories/Reals/Rtrigo_reg.v +++ b/theories/Reals/Rtrigo_reg.v @@ -251,6 +251,7 @@ Proof. exists delta; intros. rewrite Rplus_0_l; replace (cos h - cos 0) with (-2 * Rsqr (sin (h / 2))). unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. + change (-2) with (-(2)). unfold Rdiv; do 2 rewrite Ropp_mult_distr_l_reverse. rewrite Rabs_Ropp. replace (2 * Rsqr (sin (h * / 2)) * / h) with @@ -266,7 +267,7 @@ Proof. apply Rabs_pos. assert (H9 := SIN_bound (h / 2)). unfold Rabs; case (Rcase_abs (sin (h / 2))); intro. - pattern 1 at 3; rewrite <- (Ropp_involutive 1). + rewrite <- (Ropp_involutive 1). apply Ropp_le_contravar. elim H9; intros; assumption. elim H9; intros; assumption. diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v index d43baee8c..12d5cbbf0 100644 --- a/theories/Reals/Sqrt_reg.v +++ b/theories/Reals/Sqrt_reg.v @@ -21,6 +21,7 @@ Proof. destruct (total_order_T h 0) as [[Hlt|Heq]|Hgt]. repeat rewrite Rabs_left. unfold Rminus; do 2 rewrite <- (Rplus_comm (-1)). + change (-1) with (-(1)). do 2 rewrite Ropp_plus_distr; rewrite Ropp_involutive; apply Rplus_le_compat_l. apply Ropp_le_contravar; apply sqrt_le_1. -- cgit v1.2.3 From d6ced637d9b7acabef2ccc9e761ec149bc7c93da Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sun, 5 Mar 2017 21:46:26 +0100 Subject: Mark ring morphisms as opaque. This prevents Coq from unfolding IZR in ring_simplify and field_simplify. This is a change of behavior for users of morphism rings, so they might have to pass the postprocess option to Add Ring/Field if they want morphisms to be automatically expanded. There are two predefined morphisms in the standard library: IDphi (when polynomial coefficients have the same type as constants) and gen_phiZ (when the only available constants are 0 and 1). They are hardcoded as transparent. --- plugins/setoid_ring/newring.ml | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) (limited to 'plugins') diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 2a3d66934..87ee66660 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -323,11 +323,13 @@ let _ = add_map "ring" (map_with_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); + my_reference "IDphi", (function _->Eval); + my_reference "gen_phiZ", (function _->Eval); (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); pol_cst "Pphi_pow", - (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); + (function -1|8|9|10|13|15|17->Eval|11|16->Rec|_->Prot); (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) pol_cst "PEeval", (function -1|8|10|13->Eval|12->Rec|_->Prot)]) @@ -756,12 +758,14 @@ let _ = add_map "field" (map_with_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); + my_reference "IDphi", (function _->Eval); + my_reference "gen_phiZ", (function _->Eval); (* display_linear: evaluate polynomials and coef operations, protect field operations and make recursive call on the var map *) my_reference "display_linear", (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot); my_reference "display_pow_linear", - (function -1|9|10|11|12|14|16|18|19->Eval|17->Rec|_->Prot); + (function -1|9|10|11|14|16|18|19->Eval|12|17->Rec|_->Prot); (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); @@ -778,9 +782,11 @@ let _ = add_map "field_cond" (map_without_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); - (* PCond: evaluate morphism and denum list, protect ring + my_reference "IDphi", (function _->Eval); + my_reference "gen_phiZ", (function _->Eval); + (* PCond: evaluate denum list, protect ring operations and make recursive call on the var map *) - my_reference "PCond", (function -1|9|11|14->Eval|13->Rec|_->Prot)]);; + my_reference "PCond", (function -1|11|14->Eval|9|13->Rec|_->Prot)]);; let _ = Redexpr.declare_reduction "simpl_field_expr" -- cgit v1.2.3 From 6d2802075606dcddb02dd13cbaf38ff76f8bf242 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 23 Mar 2017 01:13:38 +0100 Subject: Add empty Extraction.v and FunInd.v to prepare landing of PR#220. This way, after we merge PR#220, scripts can be fixed in a way that is compatible with the 8.6 and trunk branches. --- plugins/extraction/Extraction.v | 0 plugins/extraction/vo.itarget | 1 + plugins/funind/FunInd.v | 0 plugins/funind/vo.itarget | 1 + 4 files changed, 2 insertions(+) create mode 100644 plugins/extraction/Extraction.v create mode 100644 plugins/funind/FunInd.v (limited to 'plugins') diff --git a/plugins/extraction/Extraction.v b/plugins/extraction/Extraction.v new file mode 100644 index 000000000..e69de29bb diff --git a/plugins/extraction/vo.itarget b/plugins/extraction/vo.itarget index 9c30c5eb3..3563f71df 100644 --- a/plugins/extraction/vo.itarget +++ b/plugins/extraction/vo.itarget @@ -1,3 +1,4 @@ +Extraction.vo ExtrHaskellBasic.vo ExtrHaskellNatNum.vo ExtrHaskellNatInt.vo diff --git a/plugins/funind/FunInd.v b/plugins/funind/FunInd.v new file mode 100644 index 000000000..e69de29bb diff --git a/plugins/funind/vo.itarget b/plugins/funind/vo.itarget index 33c968302..a17a5ec12 100644 --- a/plugins/funind/vo.itarget +++ b/plugins/funind/vo.itarget @@ -1 +1,2 @@ +FunInd.vo Recdef.vo -- cgit v1.2.3 From 9c38a23ae84e1542ab1eeab6ded4201718ec1cf8 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 23 Mar 2017 14:50:56 +0100 Subject: Revert "Add empty Extraction.v and FunInd.v to prepare landing of PR#220." This reverts commit 6d2802075606dcddb02dd13cbaf38ff76f8bf242, which is an 8.6 only commit. --- plugins/extraction/Extraction.v | 0 plugins/extraction/vo.itarget | 1 - plugins/funind/FunInd.v | 0 plugins/funind/vo.itarget | 1 - 4 files changed, 2 deletions(-) delete mode 100644 plugins/extraction/Extraction.v delete mode 100644 plugins/funind/FunInd.v (limited to 'plugins') diff --git a/plugins/extraction/Extraction.v b/plugins/extraction/Extraction.v deleted file mode 100644 index e69de29bb..000000000 diff --git a/plugins/extraction/vo.itarget b/plugins/extraction/vo.itarget index 3563f71df..9c30c5eb3 100644 --- a/plugins/extraction/vo.itarget +++ b/plugins/extraction/vo.itarget @@ -1,4 +1,3 @@ -Extraction.vo ExtrHaskellBasic.vo ExtrHaskellNatNum.vo ExtrHaskellNatInt.vo diff --git a/plugins/funind/FunInd.v b/plugins/funind/FunInd.v deleted file mode 100644 index e69de29bb..000000000 diff --git a/plugins/funind/vo.itarget b/plugins/funind/vo.itarget index a17a5ec12..33c968302 100644 --- a/plugins/funind/vo.itarget +++ b/plugins/funind/vo.itarget @@ -1,2 +1 @@ -FunInd.vo Recdef.vo -- cgit v1.2.3