From aa99fc9ed78a0246d11d53dde502773a915b1022 Mon Sep 17 00:00:00 2001 From: aspiwack Date: Thu, 22 Apr 2010 19:20:00 +0000 Subject: Here comes the commit, announced long ago, of the new tactic engine. This is a fairly large commit (around 140 files and 7000 lines of code impacted), it will cause some troubles for sure (I've listed the know regressions below, there is bound to be more). At this state of developpement it brings few features to the user, as the old tactics were ported with no change. Changes are on the side of the developer mostly. Here comes a list of the major changes. I will stay brief, but the code is hopefully well documented so that it is reasonably easy to infer the details from it. Feature developer-side: * Primitives for a "real" refine tactic (generating a goal for each evar). * Abstract type of tactics, goals and proofs * Tactics can act on several goals (formally all the focused goals). An interesting consequence of this is that the tactical (. ; [ . | ... ]) can be separated in two tacticals (. ; .) and ( [ . | ... ] ) (although there is a conflict for this particular syntax). We can also imagine a tactic to reorder the goals. * Possibility for a tactic to pass a value to following tactics (a typical example is an intro function which tells the following tactics which name it introduced). * backtracking primitives for tactics (it is now possible to implement a tactical '+' with (a+b);c equivalent to (a;c+b;c) (itself equivalent to (a;c||b;c)). This is a valuable tool to implement tactics like "auto" without nowing of the implementation of tactics. * A notion of proof modes, which allows to dynamically change the parser for tactics. It is controlled at user level with the keywords Set Default Proof Mode (this is the proof mode which is loaded at the start of each proof) and Proof Mode (switches the proof mode of the current proof) to control them. * A new primitive Evd.fold_undefined which operates like an Evd.fold, except it only goes through the evars whose body is Evar_empty. This is a common operation throughout the code, some of the fold-and-test-if-empty occurences have been replaced by fold_undefined. For now, it is only implemented as a fold-and-test, but we expect to have some optimisations coming some day, as there can be a lot of evars in an evar_map with this new implementation (I've observed a couple of thousands), whereas there are rarely more than a dozen undefined ones. Folding being a linear operation, this might result in a significant speed-up. * The declarative mode has been moved into the plugins. This is made possible by the proof mode feature. I tried to document it so that it can serve as a tutorial for a tactic mode plugin. Features user-side: * Unfocus does not go back to the root of the proof if several Focus-s have been performed. It only goes back to the point where it was last focused. * experimental (non-documented) support of keywords BeginSubproof/EndSubproof: BeginSubproof focuses on first goal, one can unfocus only with EndSubproof, and only if the proof is completed for that goal. * experimental (non-documented) support for bullets ('+', '-' and '*') they act as hierarchical BeginSubproof/EndSubproof: First time one uses '+' (for instance) it focuses on first goal, when the subproof is completed, one can use '+' again which unfocuses and focuses on next first goal. Meanwhile, one cas use '*' (for instance) to focus more deeply. Known regressions: * The xml plugin had some functions related to proof trees. As the structure of proof changed significantly, they do not work anymore. * I do not know how to implement info or show script in this new engine. Actually I don't even know what they were suppose to actually mean in earlier versions either. I wager they would require some calm thinking before going back to work. * Declarative mode not entirely working (in particular proofs by induction need to be restored). * A bug in the inversion tactic (observed in some contributions) * A bug in Program (observed in some contributions) * Minor change in the 'old' type of tactics causing some contributions to fail. * Compilation time takes about 10-15% longer for unknown reasons (I suspect it might be linked to the fact that I don't perform any reduction at QED-s, and also to some linear operations on evar_map-s (see Evd.fold_undefined above)). git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@12961 85f007b7-540e-0410-9357-904b9bb8a0f7 --- Makefile.common | 5 +- dev/base_include | 6 +- dev/printers.mllib | 9 +- dev/top_printers.ml | 28 +- ide/coq.ml | 41 +- ide/coqide.ml | 24 +- kernel/cbytegen.ml | 17 +- kernel/cooking.ml | 2 +- kernel/term.mli | 4 +- lib/bstack.ml | 75 - lib/bstack.mli | 22 - lib/edit.ml | 134 -- lib/edit.mli | 63 - lib/lib.mllib | 4 +- lib/store.ml | 63 + lib/store.mli | 27 + parsing/egrammar.ml | 5 +- parsing/egrammar.mli | 2 +- parsing/g_decl_mode.ml4 | 252 ---- parsing/g_proofs.ml4 | 4 + parsing/g_vernac.ml4 | 55 +- parsing/grammar.mllib | 1 + parsing/highparsing.mllib | 1 - parsing/parsing.mllib | 1 - parsing/pcoq.ml4 | 2 - parsing/pcoq.mli | 1 - parsing/ppdecl_proof.ml | 190 --- parsing/ppdecl_proof.mli | 2 - parsing/ppvernac.ml | 13 +- parsing/printer.ml | 79 +- parsing/printer.mli | 8 +- parsing/tactic_printer.ml | 89 +- parsing/tactic_printer.mli | 1 - parsing/vernacextend.ml4 | 20 +- plugins/cc/ccalgo.ml | 10 +- plugins/cc/cctac.ml | 4 +- plugins/decl_mode/decl_expr.mli | 105 ++ plugins/decl_mode/decl_interp.ml | 472 +++++++ plugins/decl_mode/decl_interp.mli | 18 + plugins/decl_mode/decl_mode.ml | 110 ++ plugins/decl_mode/decl_mode.mli | 74 + plugins/decl_mode/decl_mode_plugin.mllib | 7 + plugins/decl_mode/decl_proof_instr.ml | 1496 ++++++++++++++++++++ plugins/decl_mode/decl_proof_instr.mli | 115 ++ plugins/decl_mode/g_decl_mode.ml4 | 407 ++++++ plugins/decl_mode/ppdecl_proof.ml | 190 +++ plugins/decl_mode/ppdecl_proof.mli | 2 + plugins/firstorder/ground.ml | 28 +- plugins/funind/functional_principles_proofs.ml | 2 +- plugins/funind/indfun_common.ml | 45 +- plugins/funind/indfun_common.mli | 7 - plugins/funind/invfun.ml | 2 +- plugins/funind/recdef.ml | 10 +- plugins/pluginsbyte.itarget | 1 + plugins/pluginsopt.itarget | 1 + plugins/quote/quote.ml | 1 - plugins/ring/ring.ml | 1 - plugins/rtauto/refl_tauto.ml | 5 +- plugins/setoid_ring/newring.ml4 | 6 +- plugins/subtac/eterm.ml | 6 +- plugins/subtac/subtac.ml | 4 +- plugins/subtac/subtac_obligations.ml | 1 + plugins/xml/dumptree.ml4 | 28 +- plugins/xml/proof2aproof.ml | 82 +- plugins/xml/proofTree2Xml.ml4 | 9 +- plugins/xml/xmlcommand.ml | 29 +- pretyping/clenv.ml | 478 ------- pretyping/clenv.mli | 143 -- pretyping/evarutil.ml | 22 +- pretyping/evarutil.mli | 4 + pretyping/evd.ml | 59 +- pretyping/evd.mli | 11 +- pretyping/pretyping.mllib | 1 - pretyping/typeclasses.ml | 15 +- pretyping/typeclasses.mli | 4 - proofs/clenv.ml | 488 +++++++ proofs/clenv.mli | 143 ++ proofs/clenvtac.ml | 1 - proofs/decl_expr.mli | 105 -- proofs/decl_mode.ml | 127 -- proofs/decl_mode.mli | 74 - proofs/evar_refiner.ml | 18 +- proofs/evar_refiner.mli | 2 +- proofs/goal.ml | 572 ++++++++ proofs/goal.mli | 228 ++++ proofs/logic.ml | 287 ++-- proofs/logic.mli | 3 - proofs/pfedit.ml | 369 ++--- proofs/pfedit.mli | 57 +- proofs/proof.ml | 294 ++++ proofs/proof.mli | 133 ++ proofs/proof_global.ml | 295 ++++ proofs/proof_global.mli | 89 ++ proofs/proof_trees.ml | 107 -- proofs/proof_trees.mli | 48 - proofs/proof_type.ml | 13 +- proofs/proof_type.mli | 12 +- proofs/proofs.mllib | 9 +- proofs/proofview.ml | 491 +++++++ proofs/proofview.mli | 203 +++ proofs/refiner.ml | 619 +-------- proofs/refiner.mli | 83 +- proofs/tacmach.ml | 51 +- proofs/tacmach.mli | 38 +- proofs/tactic_debug.ml | 12 +- tactics/auto.ml | 7 +- tactics/autorewrite.ml | 6 +- tactics/class_tactics.ml4 | 141 +- tactics/decl_interp.ml | 472 ------- tactics/decl_interp.mli | 18 - tactics/decl_proof_instr.ml | 1518 --------------------- tactics/decl_proof_instr.mli | 119 -- tactics/eauto.ml4 | 20 +- tactics/eqdecide.ml4 | 1 - tactics/evar_tactics.ml | 4 +- tactics/hipattern.ml4 | 1 - tactics/hipattern.mli | 1 - tactics/leminv.ml | 46 +- tactics/refine.ml | 2 - tactics/rewrite.ml4 | 18 +- tactics/tacinterp.ml | 19 +- tactics/tacinterp.mli | 2 +- tactics/tacticals.ml | 2 +- tactics/tacticals.mli | 2 +- tactics/tactics.ml | 7 +- tactics/tactics.mllib | 2 - theories/Classes/RelationClasses.v | 2 +- theories/Init/Prelude.v | 2 + theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v | 2 +- theories/Numbers/Cyclic/Int31/Cyclic31.v | 2 +- theories/Program/Tactics.v | 6 +- theories/Reals/RiemannInt.v | 2 +- toplevel/auto_ind_decl.ml | 4 +- toplevel/himsg.ml | 7 + toplevel/lemmas.mli | 2 +- toplevel/vernacentries.ml | 244 ++-- toplevel/vernacentries.mli | 11 + toplevel/vernacexpr.ml | 17 +- toplevel/whelp.ml4 | 3 +- 139 files changed, 6922 insertions(+), 6026 deletions(-) delete mode 100644 lib/bstack.ml delete mode 100644 lib/bstack.mli delete mode 100644 lib/edit.ml delete mode 100644 lib/edit.mli create mode 100644 lib/store.ml create mode 100644 lib/store.mli delete mode 100644 parsing/g_decl_mode.ml4 delete mode 100644 parsing/ppdecl_proof.ml delete mode 100644 parsing/ppdecl_proof.mli create mode 100644 plugins/decl_mode/decl_expr.mli create mode 100644 plugins/decl_mode/decl_interp.ml create mode 100644 plugins/decl_mode/decl_interp.mli create mode 100644 plugins/decl_mode/decl_mode.ml create mode 100644 plugins/decl_mode/decl_mode.mli create mode 100644 plugins/decl_mode/decl_mode_plugin.mllib create mode 100644 plugins/decl_mode/decl_proof_instr.ml create mode 100644 plugins/decl_mode/decl_proof_instr.mli create mode 100644 plugins/decl_mode/g_decl_mode.ml4 create mode 100644 plugins/decl_mode/ppdecl_proof.ml create mode 100644 plugins/decl_mode/ppdecl_proof.mli delete mode 100644 pretyping/clenv.ml delete mode 100644 pretyping/clenv.mli create mode 100644 proofs/clenv.ml create mode 100644 proofs/clenv.mli delete mode 100644 proofs/decl_expr.mli delete mode 100644 proofs/decl_mode.ml delete mode 100644 proofs/decl_mode.mli create mode 100644 proofs/goal.ml create mode 100644 proofs/goal.mli create mode 100644 proofs/proof.ml create mode 100644 proofs/proof.mli create mode 100644 proofs/proof_global.ml create mode 100644 proofs/proof_global.mli delete mode 100644 proofs/proof_trees.ml delete mode 100644 proofs/proof_trees.mli create mode 100644 proofs/proofview.ml create mode 100644 proofs/proofview.mli delete mode 100644 tactics/decl_interp.ml delete mode 100644 tactics/decl_interp.mli delete mode 100644 tactics/decl_proof_instr.ml delete mode 100644 tactics/decl_proof_instr.mli diff --git a/Makefile.common b/Makefile.common index e3a94f56de..4d5e00d251 100644 --- a/Makefile.common +++ b/Makefile.common @@ -73,7 +73,7 @@ SRCDIRS:=\ omega romega micromega quote ring dp \ setoid_ring xml extraction fourier \ cc funind firstorder field subtac \ - rtauto groebner syntax) + rtauto groebner syntax decl_mode) # Order is relevent here because kernel and checker contain files # with the same name @@ -188,10 +188,12 @@ OTHERSYNTAXCMA:=$(addprefix plugins/syntax/, \ r_syntax_plugin.cma \ ascii_syntax_plugin.cma \ string_syntax_plugin.cma ) +DECLMODECMA:=plugins/decl_mode/decl_mode_plugin.cma PLUGINSCMA:=$(OMEGACMA) $(ROMEGACMA) $(MICROMEGACMA) \ $(QUOTECMA) $(RINGCMA) $(NEWRINGCMA) $(DPCMA) $(FIELDCMA) \ $(FOURIERCMA) $(EXTRACTIONCMA) $(XMLCMA) \ + $(DECLMODECMA) \ $(CCCMA) $(FOCMA) $(SUBTACCMA) $(RTAUTOCMA) \ $(FUNINDCMA) $(GBCMA) $(NATSYNTAXCMA) $(OTHERSYNTAXCMA) @@ -326,7 +328,6 @@ ALLMODS:=$(call vo_to_mod,$(ALLVO)) LIBFILES:=$(THEORIESVO) $(PLUGINSVO) LIBFILESLIGHT:=$(THEORIESLIGHTVO) - ########################################################################### # Miscellaneous ########################################################################### diff --git a/dev/base_include b/dev/base_include index 3a31230f19..debc074de9 100644 --- a/dev/base_include +++ b/dev/base_include @@ -110,11 +110,9 @@ open Topconstr open Prettyp open Search -open Clenvtac open Evar_refiner open Logic open Pfedit -open Proof_trees open Proof_type open Redexpr open Refiner @@ -193,12 +191,12 @@ let constbody_of_string s = Option.get b.const_body;; (* Get the current goal *) - +(* let getgoal x = top_goal_of_pftreestate (Pfedit.get_pftreestate x);; let get_nth_goal n = nth_goal_of_pftreestate n (Pfedit.get_pftreestate ());; let current_goal () = get_nth_goal 1;; - +*) let pf_e gl s = Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s);; diff --git a/dev/printers.mllib b/dev/printers.mllib index e8ec10c5cd..8ada6769cc 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -12,8 +12,7 @@ Hashcons Dyn System Envars -Bstack -Edit +Store Gset Gmap Fset @@ -93,7 +92,6 @@ Coercion Unification Cases Pretyping -Clenv Lexer Ppextend @@ -108,12 +106,15 @@ Syntax_def Implicit_quantifiers Smartlocate Constrintern -Proof_trees Tacexpr Proof_type +Goal Logic Refiner Evar_refiner +Proofview +Proof +Proof_global Pfedit Tactic_debug Decl_mode diff --git a/dev/top_printers.ml b/dev/top_printers.ml index b481e9f169..21a690f953 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -16,14 +16,11 @@ open Libnames open Nameops open Sign open Univ -open Proof_trees open Environ open Printer open Tactic_printer -open Refiner open Term open Termops -open Clenv open Cerrors open Evd open Goptions @@ -103,21 +100,24 @@ let pp_transparent_state s = pp (pr_transparent_state s) (* proof printers *) let ppmetas metas = pp(pr_metaset metas) let ppevm evd = pp(pr_evar_map evd) +(* spiwack: deactivated until a replacement is found let ppclenv clenv = pp(pr_clenv clenv) let ppgoal g = pp(db_pr_goal g) let pppftreestate p = pp(print_pftreestate p) +*) -let pr_gls gls = - hov 0 (pr_evar_map (sig_sig gls) ++ fnl () ++ db_pr_goal (sig_it gls)) +(* let ppgoal g = pp(db_pr_goal g) *) +(* let pr_gls gls = *) +(* hov 0 (pr_evar_defs (sig_sig gls) ++ fnl () ++ db_pr_goal (sig_it gls)) *) -let pr_glls glls = - hov 0 (pr_evar_map (sig_sig glls) ++ fnl () ++ - prlist_with_sep pr_fnl db_pr_goal (sig_it glls)) +(* let pr_glls glls = *) +(* hov 0 (pr_evar_defs (sig_sig glls) ++ fnl () ++ *) +(* prlist_with_sep pr_fnl db_pr_goal (sig_it glls)) *) -let ppsigmagoal g = pp(pr_goal (sig_it g)) -let prgls gls = pp(pr_gls gls) -let prglls glls = pp(pr_glls glls) -let pproof p = pp(print_proof Evd.empty empty_named_context p) +(* let ppsigmagoal g = pp(pr_goal (sig_it g)) *) +(* let prgls gls = pp(pr_gls gls) *) +(* let prglls glls = pp(pr_glls glls) *) +(* let pproof p = pp(print_proof Evd.empty empty_named_context p) *) let ppuni u = pp(pr_uni u) @@ -402,7 +402,7 @@ let _ = with e -> Pp.pp (Cerrors.explain_exn e) let _ = - extend_vernac_command_grammar "PrintConstr" + extend_vernac_command_grammar "PrintConstr" None [[GramTerminal "PrintConstr"; GramNonTerminal (dummy_loc,ConstrArgType,Extend.Aentry ("constr","constr"), @@ -419,7 +419,7 @@ let _ = with e -> Pp.pp (Cerrors.explain_exn e) let _ = - extend_vernac_command_grammar "PrintPureConstr" + extend_vernac_command_grammar "PrintPureConstr" None [[GramTerminal "PrintPureConstr"; GramNonTerminal (dummy_loc,ConstrArgType,Extend.Aentry ("constr","constr"), diff --git a/ide/coq.ml b/ide/coq.ml index 87f0c35e65..9b0afc7bed 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -19,7 +19,6 @@ open Printer open Environ open Evarutil open Evd -open Decl_mode open Hipattern open Tacmach open Reductionops @@ -90,11 +89,6 @@ let version () = let is_in_loadpath coqtop dir = Library.is_in_load_paths (System.physical_path_of_string dir) -let is_in_proof_mode () = - match Decl_mode.get_current_mode () with - Decl_mode.Mode_none -> false - | _ -> true - let user_error_loc l s = raise (Stdpp.Exc_located (l, Util.UserError ("CoqIde", s))) @@ -169,11 +163,6 @@ let rec attribute_of_vernac_command = function | VernacSolve _ -> [SolveCommand] | VernacSolveExistential _ -> [SolveCommand] - (* MMode *) - | VernacDeclProof -> [SolveCommand] - | VernacReturn -> [SolveCommand] - | VernacProofInstr _ -> [SolveCommand] - (* Auxiliary file and library management *) | VernacRequireFrom _ -> [] | VernacAddLoadPath _ -> [] @@ -241,9 +230,15 @@ let rec attribute_of_vernac_command = function | VernacProof (Tacexpr.TacId []) -> [OtherStatePreservingCommand] | VernacProof _ -> [] + | VernacProofMode _ -> [] + + | VernacSubproof _ -> [SolveCommand] + | VernacEndSubproof _ -> [SolveCommand] + (* Toplevel control *) | VernacToplevelControl _ -> [] + (* Extensions *) | VernacExtend ("Subtac_Obligations", _) -> [GoalStartingCommand] | VernacExtend _ -> [] @@ -508,13 +503,13 @@ let hyp_next_tac sigma env (id,_,ast) = ("inversion clear "^id_s), ("inversion_clear "^id_s^".\n") ] -let concl_next_tac concl = +let concl_next_tac sigma concl = let expand s = (s,s^".\n") in List.map expand ([ "intro"; "intros"; "intuition" - ] @ (if Hipattern.is_equality_type concl.Evd.evar_concl then [ + ] @ (if Hipattern.is_equality_type (Goal.V82.concl sigma concl) then [ "reflexivity"; "discriminate"; "symmetry" @@ -538,30 +533,26 @@ let concl_next_tac concl = let goals coqtop = PrintOpt.enforce_hack (); let pfts = Pfedit.get_pftreestate () in - let sigma = Tacmach.evc_of_pftreestate pfts in - let (all_goals,_) = Refiner.frontier (Refiner.proof_of_pftreestate pfts) in + let { it=all_goals ; sigma=sigma } = Proof.V82.subgoals pfts in if all_goals = [] then begin Message ( - match Decl_mode.get_end_command pfts with - | Some c -> "Subproof completed, now type "^c^".\n" - | None -> - let exl = Evarutil.non_instantiated sigma in - if exl = [] then "Proof Completed.\n" else - ("No more subgoals but non-instantiated existential variables:\n"^ - string_of_ppcmds (pr_evars_int 1 exl))) + let exl = Evarutil.non_instantiated sigma in + if exl = [] then "Proof Completed.\n" else + ("No more subgoals but non-instantiated existential variables:\n"^ + string_of_ppcmds (pr_evars_int 1 exl))) end else begin let process_goal g = - let env = Evd.evar_env g in + let env = Goal.V82.env sigma g in let ccl = - string_of_ppcmds (pr_ltype_env_at_top env g.Evd.evar_concl) in + string_of_ppcmds (pr_ltype_env_at_top env (Goal.V82.concl sigma g)) in let process_hyp h_env d acc = (string_of_ppcmds (pr_var_decl h_env d), hyp_next_tac sigma h_env d)::acc in let hyps = List.rev (Environ.fold_named_context process_hyp env ~init:[]) in - (hyps,(ccl,concl_next_tac g)) + (hyps,(ccl,concl_next_tac sigma g)) in Goals (List.map process_goal all_goals) end diff --git a/ide/coqide.ml b/ide/coqide.ml index 4fa0c28f51..5d604a62bf 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -730,14 +730,10 @@ object(self) (String.make previous_line_spaces ' ') end + method show_goals = try - match Decl_mode.get_current_mode () with - Decl_mode.Mode_none -> () - | Decl_mode.Mode_tactic -> - Ideproof.display (Ideproof.mode_tactic (fun _ _ -> ())) proof_view (Coq.goals Coq.dummy_coqtop) - | Decl_mode.Mode_proof -> - Ideproof.display Ideproof.mode_cesar proof_view (Coq.goals Coq.dummy_coqtop) + Ideproof.display (Ideproof.mode_tactic (fun _ _ -> ())) proof_view (Coq.goals Coq.dummy_coqtop) with e -> prerr_endline ("Don't worry be happy despite: "^Printexc.to_string e) @@ -747,15 +743,10 @@ object(self) if not full_goal_done then begin try - match Decl_mode.get_current_mode () with - Decl_mode.Mode_none -> () - | Decl_mode.Mode_tactic -> - Ideproof.display - (Ideproof.mode_tactic (fun s () -> ignore (self#insert_this_phrase_on_success - true true false ("progress "^s) s))) - proof_view (Coq.goals Coq.dummy_coqtop) - | Decl_mode.Mode_proof -> - Ideproof.display Ideproof.mode_cesar proof_view (Coq.goals Coq.dummy_coqtop) + Ideproof.display + (Ideproof.mode_tactic (fun s () -> ignore (self#insert_this_phrase_on_success + true true false ("progress "^s) s))) + proof_view (Coq.goals Coq.dummy_coqtop) with e -> prerr_endline (Printexc.to_string e) end @@ -787,9 +778,8 @@ object(self) try full_goal_done <- false; prerr_endline "Send_to_coq starting now"; - Decl_mode.clear_daimon_flag (); let r = Coq.interp Coq.dummy_coqtop verbosely phrase in - let is_complete = not (Decl_mode.get_daimon_flag ()) in + let is_complete = true in let msg = read_stdout () in sync display_output msg; Some (is_complete,r) diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index e7859962eb..68ee15ab7c 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -335,7 +335,7 @@ let rec str_const c = | App(f,args) -> begin match kind_of_term f with - | Construct((kn,j),i) -> (* arnaud: Construct(((kn,j),i) as cstr) -> *) + | Construct((kn,j),i) -> begin let oib = lookup_mind kn !global_env in let oip = oib.mind_packets.(j) in @@ -405,7 +405,7 @@ let rec str_const c = | _ -> Bconstr c end | Ind ind -> Bstrconst (Const_ind ind) - | Construct ((kn,j),i) -> (*arnaud: Construct ((kn,j),i as cstr) -> *) + | Construct ((kn,j),i) -> begin (* spiwack: tries first to apply the run-time compilation behavior of the constructor, as in 2/ above *) @@ -664,19 +664,6 @@ and compile_str_cst reloc sc sz cont = (* spiwack : compilation of constants with their arguments. Makes a special treatment with 31-bit integer addition *) and compile_const = -(*arnaud: let code_construct kn cont = - let f_cont = - let else_lbl = Label.create () in - Kareconst(2, else_lbl):: Kacc 0:: Kpop 1:: - Kaddint31:: Kreturn 0:: Klabel else_lbl:: - (* works as comp_app with nargs = 2 and tailcall cont [Kreturn 0]*) - Kgetglobal (get_allias !global_env kn):: - Kappterm(2, 2):: [] (* = discard_dead_code [Kreturn 0] *) - in - let lbl = Label.create () in - fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)]; - Kclosure(lbl, 0)::cont - in *) fun reloc-> fun kn -> fun args -> fun sz -> fun cont -> let nargs = Array.length args in (* spiwack: checks if there is a specific way to compile the constant diff --git a/kernel/cooking.ml b/kernel/cooking.ml index c971ed2993..7605df9eb2 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -99,7 +99,7 @@ let expmod_constr modlist c = in if modlist = empty_modlist then c - else under_outer_cast nf_betaiota (substrec c) + else substrec c let abstract_constant_type = List.fold_left (fun c d -> mkNamedProd_wo_LetIn d c) diff --git a/kernel/term.mli b/kernel/term.mli index 1ffe5eeb5f..ff71c3594e 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -161,9 +161,9 @@ val mkFix : fixpoint -> constr (* If [funnames = [|f1,.....fn|]] [typarray = [|t1,...tn|]] [bodies = [b1,.....bn]] \par\noindent - then [mkCoFix (i, (typsarray, funnames, bodies))] + then [mkCoFix (i, (funnames, typarray, bodies))] constructs the ith function of the block - + [CoFixpoint f1 = b1 with f2 = b2 ... diff --git a/lib/bstack.ml b/lib/bstack.ml deleted file mode 100644 index 4191ccdb15..0000000000 --- a/lib/bstack.ml +++ /dev/null @@ -1,75 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* = size always and depth > size if the queue overflowed - (and forgot older elements) - *) - -type 'a t = {mutable pos : int; - mutable size : int; - mutable depth : int; - stack : 'a array} - -let create depth e = - {pos = 0; - size = 1; - depth = 1; - stack = Array.create depth e} - -(* -let set_depth bs n = bs.depth <- n -*) - -let incr_pos bs = - bs.pos <- if bs.pos = Array.length bs.stack - 1 then 0 else bs.pos + 1 - -let incr_size bs = - if bs.size < Array.length bs.stack then bs.size <- bs.size + 1 - -let decr_pos bs = - bs.pos <- if bs.pos = 0 then Array.length bs.stack - 1 else bs.pos - 1 - -let push bs e = - incr_pos bs; - incr_size bs; - bs.depth <- bs.depth + 1; - bs.stack.(bs.pos) <- e - -let pop bs = - if bs.size > 1 then begin - bs.size <- bs.size - 1; - bs.depth <- bs.depth - 1; - let oldpos = bs.pos in - decr_pos bs; - (* Release the memory at oldpos, by copying what is at new pos *) - bs.stack.(oldpos) <- bs.stack.(bs.pos) - end - -let top bs = - if bs.size >= 1 then bs.stack.(bs.pos) - else error "Nothing on the stack" - -let app_push bs f = - if bs.size = 0 then error "Nothing on the stack" - else push bs (f (bs.stack.(bs.pos))) - -let app_repl bs f = - if bs.size = 0 then error "Nothing on the stack" - else bs.stack.(bs.pos) <- f (bs.stack.(bs.pos)) - -let depth bs = bs.depth - -let size bs = bs.size diff --git a/lib/bstack.mli b/lib/bstack.mli deleted file mode 100644 index cef8e1d9e5..0000000000 --- a/lib/bstack.mli +++ /dev/null @@ -1,22 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a -> 'a t -val push : 'a t -> 'a -> unit -val app_push : 'a t -> ('a -> 'a) -> unit -val app_repl : 'a t -> ('a -> 'a) -> unit -val pop : 'a t -> unit -val top : 'a t -> 'a -val depth : 'a t -> int -val size : 'a t -> int diff --git a/lib/edit.ml b/lib/edit.ml deleted file mode 100644 index fd870a21ba..0000000000 --- a/lib/edit.ml +++ /dev/null @@ -1,134 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* nd -> - e.last_focused_stk <- foc::(list_except foc e.last_focused_stk); - | _ -> () - end; - e.focus <- Some nd - -let unfocus e = - match e.focus with - | None -> invalid_arg "Edit.unfocus" - | Some foc -> - begin - e.last_focused_stk <- foc::(list_except foc e.last_focused_stk); - e.focus <- None - end - -let last_focused e = - match e.last_focused_stk with - | [] -> None - | f::_ -> Some f - -let restore_last_focus e = - match e.last_focused_stk with - | [] -> () - | f::_ -> focus e f - -let focusedp e = - match e.focus with - | None -> false - | _ -> true - -let read e = - match e.focus with - | None -> None - | Some d -> - let (bs,c) = Hashtbl.find e.buf d in - Some(d,Bstack.top bs,c) - -let mutate e f = - match e.focus with - | None -> invalid_arg "Edit.mutate" - | Some d -> - let (bs,c) = Hashtbl.find e.buf d in - Bstack.app_push bs (f c) - -let rev_mutate e f = - match e.focus with - | None -> invalid_arg "Edit.rev_mutate" - | Some d -> - let (bs,c) = Hashtbl.find e.buf d in - Bstack.app_repl bs (f c) - -let undo e n = - match e.focus with - | None -> invalid_arg "Edit.undo" - | Some d -> - let (bs,_) = Hashtbl.find e.buf d in - if n >= Bstack.size bs then - errorlabstrm "Edit.undo" (str"Undo stack exhausted"); - repeat n Bstack.pop bs - -(* Return the depth of the focused proof of [e] stack, this is used to - put informations in coq prompt (in emacs mode). *) -let depth e = - match e.focus with - | None -> invalid_arg "Edit.depth" - | Some d -> - let (bs,_) = Hashtbl.find e.buf d in - Bstack.depth bs - -(* Undo focused proof of [e] to reach depth [n] *) -let undo_todepth e n = - match e.focus with - | None -> - if n <> 0 - then errorlabstrm "Edit.undo_todepth" (str"No proof in progress") - else () (* if there is no proof in progress, then n must be zero *) - | Some d -> - let (bs,_) = Hashtbl.find e.buf d in - let ucnt = Bstack.depth bs - n in - if ucnt >= Bstack.size bs then - errorlabstrm "Edit.undo_todepth" (str"Undo stack would be exhausted"); - repeat ucnt Bstack.pop bs - -let create e (d,b,c,usize) = - if Hashtbl.mem e.buf d then - errorlabstrm "Edit.create" - (str"Already editing something of that name"); - let bs = Bstack.create usize b in - Hashtbl.add e.buf d (bs,c) - -let delete e d = - if not(Hashtbl.mem e.buf d) then - errorlabstrm "Edit.delete" (str"No such editor"); - Hashtbl.remove e.buf d; - e.last_focused_stk <- (list_except d e.last_focused_stk); - match e.focus with - | Some d' -> if d = d' then (e.focus <- None ; (restore_last_focus e)) - | None -> () - -let dom e = - let l = ref [] in - Hashtbl.iter (fun x _ -> l := x :: !l) e.buf; - !l - -let clear e = - e.focus <- None; - e.last_focused_stk <- []; - Hashtbl.clear e.buf diff --git a/lib/edit.mli b/lib/edit.mli deleted file mode 100644 index d13d9c6f69..0000000000 --- a/lib/edit.mli +++ /dev/null @@ -1,63 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'b], which knows how to apply - * modification functions to the value in the range, and how to - * focus on a member of the range. - * It also supports the notion of a limited-depth undo, and that certain - * modification actions do not push onto the undo stack, since they are - * reversible. *) - -type ('a,'b,'c) t - -val empty : unit -> ('a,'b,'c) t - -(* sets the focus to the specified domain element *) -val focus : ('a,'b,'c) t -> 'a -> unit - -(* unsets the focus which must not already be unfocused *) -val unfocus : ('a,'b,'c) t -> unit - -(* gives the last focused element or [None] if none *) -val last_focused : ('a,'b,'c) t -> 'a option - -(* are we focused ? *) -val focusedp : ('a,'b,'c) t -> bool - -(* If we are focused, then return the current domain,range pair. *) -val read : ('a,'b,'c) t -> ('a * 'b * 'c) option - -(* mutates the currently-focused range element, pushing its - * old value onto the undo stack - *) -val mutate : ('a,'b,'c) t -> ('c -> 'b -> 'b) -> unit - -(* mutates the currently-focused range element, in place. *) -val rev_mutate : ('a,'b,'c) t -> ('c -> 'b -> 'b) -> unit - -(* Pops the specified number of elements off of the undo stack, * - reinstating the last popped element. The undo stack is independently - managed for each range element. *) -val undo : ('a,'b,'c) t -> int -> unit - -val create : ('a,'b,'c) t -> 'a * 'b * 'c * int -> unit -val delete : ('a,'b,'c) t -> 'a -> unit - -val dom : ('a,'b,'c) t -> 'a list - -val clear : ('a,'b,'c) t -> unit - -(* [depth e] Returns the depth of the focused proof stack of [e], this - is used to put informations in coq prompt (in emacs mode). *) -val depth : ('a,'b,'c) t -> int - -(* [undo_todepth e n] Undoes focused proof of [e] to reach depth [n] *) -val undo_todepth : ('a,'b,'c) t -> int -> unit diff --git a/lib/lib.mllib b/lib/lib.mllib index 1743ce26ca..86d29c4be6 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -10,8 +10,6 @@ Hashcons Dyn System Envars -Bstack -Edit Gset Gmap Fset @@ -26,4 +24,4 @@ Rtree Heap Option Dnet - +Store diff --git a/lib/store.ml b/lib/store.ml new file mode 100644 index 0000000000..8f1309531e --- /dev/null +++ b/lib/store.ml @@ -0,0 +1,63 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t ; + get : t -> 'a option + } + + val embed : unit -> 'a etype +end + +(* We use a dynamic "name" allocator. But if we needed to serialise stores, we +might want something static to avoid troubles with plugins order. *) + +let next = + let count = ref 0 in fun () -> + let n = !count in + incr count; + n + +type t = Obj.t Util.Intmap.t + +module Field = struct + type 'a field = { + set : 'a -> t -> t ; + get : t -> 'a option ; + remove : t -> t + } + type 'a t = 'a field +end + +open Field + +let empty = Util.Intmap.empty + +let field () = + let fid = next () in + let set a s = + Util.Intmap.add fid (Obj.repr a) s + in + let get s = + try Some (Obj.obj (Util.Intmap.find fid s)) + with _ -> None + in + let remove s = + Util.Intmap.remove fid s + in + { set = set ; get = get ; remove = remove } diff --git a/lib/store.mli b/lib/store.mli new file mode 100644 index 0000000000..0caeb2abba --- /dev/null +++ b/lib/store.mli @@ -0,0 +1,27 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t -> t ; + get : t -> 'a option ; + remove : t -> t + } + type 'a t = 'a field +end + +val empty : t + +val field : unit -> 'a Field.field diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml index 023ec0f3c7..b5ee1ae60c 100644 --- a/parsing/egrammar.ml +++ b/parsing/egrammar.ml @@ -222,12 +222,13 @@ let extend_tactic_grammar s gl = let vernac_exts = ref [] let get_extend_vernac_grammars () = !vernac_exts -let extend_vernac_command_grammar s gl = +let extend_vernac_command_grammar s nt gl = + let nt = Option.default Vernac_.command nt in vernac_exts := (s,gl) :: !vernac_exts; let univ = get_univ "vernac" in let mkact loc l = VernacExtend (s,List.map snd l) in let rules = List.map (make_rule univ mkact make_prod_item) gl in - Gram.extend Vernac_.command None [(None, None, List.rev rules)] + Gram.extend nt None [(None, None, List.rev rules)] (**********************************************************************) (** Grammar declaration for Tactic Notation (Coq level) *) diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli index 1228b40cf3..a45ea9549c 100644 --- a/parsing/egrammar.mli +++ b/parsing/egrammar.mli @@ -59,7 +59,7 @@ val extend_tactic_grammar : string -> grammar_prod_item list list -> unit val extend_vernac_command_grammar : - string -> grammar_prod_item list list -> unit + string -> vernac_expr Gram.Entry.e option -> grammar_prod_item list list -> unit val get_extend_vernac_grammars : unit -> (string * grammar_prod_item list list) list diff --git a/parsing/g_decl_mode.ml4 b/parsing/g_decl_mode.ml4 deleted file mode 100644 index e73e54e7f5..0000000000 --- a/parsing/g_decl_mode.ml4 +++ /dev/null @@ -1,252 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* [] - | Some l -> l - -GEXTEND Gram -GLOBAL: proof_instr; - thesis : - [[ "thesis" -> Plain - | "thesis"; "for"; i=ident -> (For i) - ]]; - statement : - [[ i=ident ; ":" ; c=constr -> {st_label=Name i;st_it=c} - | i=ident -> {st_label=Anonymous; - st_it=Topconstr.CRef (Libnames.Ident (loc, i))} - | c=constr -> {st_label=Anonymous;st_it=c} - ]]; - constr_or_thesis : - [[ t=thesis -> Thesis t ] | - [ c=constr -> This c - ]]; - statement_or_thesis : - [ - [ t=thesis -> {st_label=Anonymous;st_it=Thesis t} ] - | - [ i=ident ; ":" ; cot=constr_or_thesis -> {st_label=Name i;st_it=cot} - | i=ident -> {st_label=Anonymous; - st_it=This (Topconstr.CRef (Libnames.Ident (loc, i)))} - | c=constr -> {st_label=Anonymous;st_it=This c} - ] - ]; - justification_items : - [[ -> Some [] - | "by"; l=LIST1 constr SEP "," -> Some l - | "by"; "*" -> None ]] - ; - justification_method : - [[ -> None - | "using"; tac = tactic -> Some tac ]] - ; - simple_cut_or_thesis : - [[ ls = statement_or_thesis; - j = justification_items; - taco = justification_method - -> {cut_stat=ls;cut_by=j;cut_using=taco} ]] - ; - simple_cut : - [[ ls = statement; - j = justification_items; - taco = justification_method - -> {cut_stat=ls;cut_by=j;cut_using=taco} ]] - ; - elim_type: - [[ IDENT "induction" -> ET_Induction - | IDENT "cases" -> ET_Case_analysis ]] - ; - block_type : - [[ IDENT "claim" -> B_claim - | IDENT "focus" -> B_focus - | IDENT "proof" -> B_proof - | et=elim_type -> B_elim et ]] - ; - elim_obj: - [[ IDENT "on"; c=constr -> Real c - | IDENT "of"; c=simple_cut -> Virtual c ]] - ; - elim_step: - [[ IDENT "consider" ; - h=consider_vars ; IDENT "from" ; c=constr -> Pconsider (c,h) - | IDENT "per"; et=elim_type; obj=elim_obj -> Pper (et,obj) - | IDENT "suffices"; ls=suff_clause; - j = justification_items; - taco = justification_method - -> Psuffices {cut_stat=ls;cut_by=j;cut_using=taco} ]] - ; - rew_step : - [[ "~=" ; c=simple_cut -> (Rhs,c) - | "=~" ; c=simple_cut -> (Lhs,c)]] - ; - cut_step: - [[ "then"; tt=elim_step -> Pthen tt - | "then"; c=simple_cut_or_thesis -> Pthen (Pcut c) - | IDENT "thus"; tt=rew_step -> Pthus (let s,c=tt in Prew (s,c)) - | IDENT "thus"; c=simple_cut_or_thesis -> Pthus (Pcut c) - | IDENT "hence"; c=simple_cut_or_thesis -> Phence (Pcut c) - | tt=elim_step -> tt - | tt=rew_step -> let s,c=tt in Prew (s,c); - | IDENT "have"; c=simple_cut_or_thesis -> Pcut c; - | IDENT "claim"; c=statement -> Pclaim c; - | IDENT "focus"; IDENT "on"; c=statement -> Pfocus c; - | "end"; bt = block_type -> Pend bt; - | IDENT "escape" -> Pescape ]] - ; - (* examiner s'il est possible de faire R _ et _ R pour R une relation qcq*) - loc_id: - [[ id=ident -> fun x -> (loc,(id,x)) ]]; - hyp: - [[ id=loc_id -> id None ; - | id=loc_id ; ":" ; c=constr -> id (Some c)]] - ; - consider_vars: - [[ name=hyp -> [Hvar name] - | name=hyp; ","; v=consider_vars -> (Hvar name) :: v - | name=hyp; - IDENT "such"; IDENT "that"; h=consider_hyps -> (Hvar name)::h - ]] - ; - consider_hyps: - [[ st=statement; IDENT "and"; h=consider_hyps -> Hprop st::h - | st=statement; IDENT "and"; - IDENT "consider" ; v=consider_vars -> Hprop st::v - | st=statement -> [Hprop st] - ]] - ; - assume_vars: - [[ name=hyp -> [Hvar name] - | name=hyp; ","; v=assume_vars -> (Hvar name) :: v - | name=hyp; - IDENT "such"; IDENT "that"; h=assume_hyps -> (Hvar name)::h - ]] - ; - assume_hyps: - [[ st=statement; IDENT "and"; h=assume_hyps -> Hprop st::h - | st=statement; IDENT "and"; - IDENT "we"; IDENT "have" ; v=assume_vars -> Hprop st::v - | st=statement -> [Hprop st] - ]] - ; - assume_clause: - [[ IDENT "we" ; IDENT "have" ; v=assume_vars -> v - | h=assume_hyps -> h ]] - ; - suff_vars: - [[ name=hyp; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> - [Hvar name],c - | name=hyp; ","; v=suff_vars -> - let (q,c) = v in ((Hvar name) :: q),c - | name=hyp; - IDENT "such"; IDENT "that"; h=suff_hyps -> - let (q,c) = h in ((Hvar name) :: q),c - ]]; - suff_hyps: - [[ st=statement; IDENT "and"; h=suff_hyps -> - let (q,c) = h in (Hprop st::q),c - | st=statement; IDENT "and"; - IDENT "to" ; IDENT "have" ; v=suff_vars -> - let (q,c) = v in (Hprop st::q),c - | st=statement; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> - [Hprop st],c - ]] - ; - suff_clause: - [[ IDENT "to" ; IDENT "have" ; v=suff_vars -> v - | h=suff_hyps -> h ]] - ; - let_vars: - [[ name=hyp -> [Hvar name] - | name=hyp; ","; v=let_vars -> (Hvar name) :: v - | name=hyp; IDENT "be"; - IDENT "such"; IDENT "that"; h=let_hyps -> (Hvar name)::h - ]] - ; - let_hyps: - [[ st=statement; IDENT "and"; h=let_hyps -> Hprop st::h - | st=statement; IDENT "and"; "let"; v=let_vars -> Hprop st::v - | st=statement -> [Hprop st] - ]]; - given_vars: - [[ name=hyp -> [Hvar name] - | name=hyp; ","; v=given_vars -> (Hvar name) :: v - | name=hyp; IDENT "such"; IDENT "that"; h=given_hyps -> (Hvar name)::h - ]] - ; - given_hyps: - [[ st=statement; IDENT "and"; h=given_hyps -> Hprop st::h - | st=statement; IDENT "and"; IDENT "given"; v=given_vars -> Hprop st::v - | st=statement -> [Hprop st] - ]]; - suppose_vars: - [[name=hyp -> [Hvar name] - |name=hyp; ","; v=suppose_vars -> (Hvar name) :: v - |name=hyp; OPT[IDENT "be"]; - IDENT "such"; IDENT "that"; h=suppose_hyps -> (Hvar name)::h - ]] - ; - suppose_hyps: - [[ st=statement_or_thesis; IDENT "and"; h=suppose_hyps -> Hprop st::h - | st=statement_or_thesis; IDENT "and"; IDENT "we"; IDENT "have"; - v=suppose_vars -> Hprop st::v - | st=statement_or_thesis -> [Hprop st] - ]] - ; - suppose_clause: - [[ IDENT "we"; IDENT "have"; v=suppose_vars -> v; - | h=suppose_hyps -> h ]] - ; - intro_step: - [[ IDENT "suppose" ; h=assume_clause -> Psuppose h - | IDENT "suppose" ; IDENT "it"; IDENT "is" ; c=pattern LEVEL "0" ; - po=OPT[ "with"; p=LIST1 hyp SEP ","-> p ] ; - ho=OPT[ IDENT "and" ; h=suppose_clause -> h ] -> - Pcase (none_is_empty po,c,none_is_empty ho) - | "let" ; v=let_vars -> Plet v - | IDENT "take"; witnesses = LIST1 constr SEP "," -> Ptake witnesses - | IDENT "assume"; h=assume_clause -> Passume h - | IDENT "given"; h=given_vars -> Pgiven h - | IDENT "define"; id=ident; args=LIST0 hyp; - "as"; body=constr -> Pdefine(id,args,body) - | IDENT "reconsider"; id=ident; "as" ; typ=constr -> Pcast (This id,typ) - | IDENT "reconsider"; t=thesis; "as" ; typ=constr -> Pcast (Thesis t ,typ) - ]] - ; - emphasis : - [[ -> 0 - | "*" -> 1 - | "**" -> 2 - | "***" -> 3 - ]] - ; - bare_proof_instr: - [[ c = cut_step -> c ; - | i = intro_step -> i ]] - ; - proof_instr : - [[ e=emphasis;i=bare_proof_instr -> {emph=e;instr=i}]] - ; -END;; - - diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 39e577b88c..27ad1e9645 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -40,6 +40,7 @@ GEXTEND Gram [ [ IDENT "Goal"; c = lconstr -> VernacGoal c | IDENT "Proof" -> VernacProof (Tacexpr.TacId []) | IDENT "Proof"; "with"; ta = tactic -> VernacProof ta + | IDENT "Proof" ; IDENT "Mode" ; mn = string -> VernacProofMode mn | IDENT "Abort" -> VernacAbort None | IDENT "Abort"; IDENT "All" -> VernacAbortAll | IDENT "Abort"; id = identref -> VernacAbort (Some id) @@ -66,6 +67,9 @@ GEXTEND Gram | IDENT "Focus" -> VernacFocus None | IDENT "Focus"; n = natural -> VernacFocus (Some n) | IDENT "Unfocus" -> VernacUnfocus + | IDENT "BeginSubproof" -> VernacSubproof None + | IDENT "BeginSubproof"; n = natural -> VernacSubproof (Some n) + | IDENT "EndSubproof" -> VernacEndSubproof | IDENT "Show" -> VernacShow (ShowGoal None) | IDENT "Show"; n = natural -> VernacShow (ShowGoal (Some n)) | IDENT "Show"; IDENT "Implicit"; IDENT "Arguments"; n = OPT natural -> diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 008a6ac510..db683b9a91 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -19,7 +19,6 @@ open Topconstr open Extend open Vernacexpr open Pcoq -open Decl_mode open Tactic open Decl_kinds open Genarg @@ -40,7 +39,6 @@ let _ = List.iter (fun s -> Lexer.add_token ("",s)) vernac_kw let check_command = Gram.Entry.create "vernac:check_command" let tactic_mode = Gram.Entry.create "vernac:tactic_command" -let proof_mode = Gram.Entry.create "vernac:proof_command" let noedit_mode = Gram.Entry.create "vernac:noedit_command" let class_rawexpr = Gram.Entry.create "vernac:class_rawexpr" @@ -50,13 +48,23 @@ let decl_notation = Gram.Entry.create "vernac:decl_notation" let typeclass_context = Gram.Entry.create "vernac:typeclass_context" let record_field = Gram.Entry.create "vernac:record_field" let of_type_with_opt_coercion = Gram.Entry.create "vernac:of_type_with_opt_coercion" +let subgoal_command = Gram.Entry.create "proof_mode:subgoal_command" let instance_name = Gram.Entry.create "vernac:instance_name" -let get_command_entry () = - match Decl_mode.get_current_mode () with - Mode_proof -> proof_mode - | Mode_tactic -> tactic_mode - | Mode_none -> noedit_mode +let command_entry = ref noedit_mode +let set_command_entry e = command_entry := e +let get_command_entry () = !command_entry + + +(* 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 set_tactic_mode () = set_command_entry tactic_mode +let set_noedit_mode () = set_command_entry noedit_mode +let _ = Proof_global.register_proof_mode {Proof_global. + name = "Classic" ; + set = set_tactic_mode ; + reset = set_noedit_mode + } let default_command_entry = Gram.Entry.of_parser "command_entry" @@ -64,7 +72,7 @@ let default_command_entry = let no_hook _ _ = () GEXTEND Gram - GLOBAL: vernac gallina_ext tactic_mode proof_mode noedit_mode; + GLOBAL: vernac gallina_ext tactic_mode noedit_mode subgoal_command; vernac: FIRST [ [ IDENT "Time"; v = vernac -> VernacTime v | IDENT "Timeout"; n = natural; v = vernac -> VernacTimeout(n,v) @@ -89,25 +97,25 @@ GEXTEND Gram | -> locality_flag := None ] ] ; noedit_mode: - [ [ c = subgoal_command -> c None] ] + [ [ c = subgoal_command -> c None None] ] ; tactic_mode: [ [ gln = OPT[n=natural; ":" -> n]; - tac = subgoal_command -> tac gln ] ] + tac = subgoal_command -> tac gln None + | b = bullet; tac = subgoal_command -> tac None (Some b)] ] + ; + bullet: + [ [ "-" -> Dash + | "*" -> Star + | "+" -> Plus ] ] ; - subgoal_command: - [ [ c = check_command; "." -> c + subgoal_command: + [ [ c = check_command; "." -> fun g _ -> c g | tac = Tactic.tactic; use_dft_tac = [ "." -> false | "..." -> true ] -> - (fun g -> - let g = match g with Some gl -> gl | _ -> 1 in - VernacSolve(g,tac,use_dft_tac)) ] ] - ; - proof_mode: - [ [ instr = proof_instr; "." -> VernacProofInstr instr ] ] - ; - proof_mode: LAST - [ [ c=subgoal_command -> c (Some 1) ] ] + (fun g b -> + let g = Option.default 1 g in + VernacSolve(g,b,tac,use_dft_tac)) ] ] ; located_vernac: [ [ v = vernac -> loc, v ] ] @@ -713,10 +721,7 @@ GEXTEND Gram | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value -> VernacRemoveOption ([table;field], v) | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value -> - VernacRemoveOption ([table], v) - - | IDENT "proof" -> VernacDeclProof - | "return" -> VernacReturn ]] + VernacRemoveOption ([table], v) ]] ; check_command: (* TODO: rapprocher Eval et Check *) [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = lconstr -> diff --git a/parsing/grammar.mllib b/parsing/grammar.mllib index 248a8ad9ad..483538da62 100644 --- a/parsing/grammar.mllib +++ b/parsing/grammar.mllib @@ -14,6 +14,7 @@ Hashcons Predicate Rtree Option +Store Names Univ diff --git a/parsing/highparsing.mllib b/parsing/highparsing.mllib index 3eb27abbb6..eed6caea30 100644 --- a/parsing/highparsing.mllib +++ b/parsing/highparsing.mllib @@ -4,4 +4,3 @@ G_prim G_proofs G_tactic G_ltac -G_decl_mode diff --git a/parsing/parsing.mllib b/parsing/parsing.mllib index c0c1817d1d..84a08d549a 100644 --- a/parsing/parsing.mllib +++ b/parsing/parsing.mllib @@ -6,7 +6,6 @@ G_xml Ppconstr Printer Pptactic -Ppdecl_proof Tactic_printer Printmod Prettyp diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 7120f72d20..de15d8a7cb 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -373,8 +373,6 @@ module Vernac_ = let command = gec_vernac "command" let syntax = gec_vernac "syntax_command" let vernac = gec_vernac "Vernac.vernac" - let proof_instr = Gram.Entry.create "proofmode:instr" - let vernac_eoi = eoi_entry vernac (* Main vernac entry *) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index ed370a9953..7ed05ed5c7 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -247,7 +247,6 @@ module Vernac_ : val syntax : vernac_expr Gram.Entry.e val vernac : vernac_expr Gram.Entry.e val vernac_eoi : vernac_expr Gram.Entry.e - val proof_instr : Decl_expr.raw_proof_instr Gram.Entry.e end (* The main entry: reads an optional vernac command *) diff --git a/parsing/ppdecl_proof.ml b/parsing/ppdecl_proof.ml deleted file mode 100644 index 40c712cdff..0000000000 --- a/parsing/ppdecl_proof.ml +++ /dev/null @@ -1,190 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* mt () - | Name id -> pr_id id ++ spc () ++ str ":" ++ spc () - -let pr_justification_items env = function - Some [] -> mt () - | Some (_::_ as l) -> - spc () ++ str "by" ++ spc () ++ - prlist_with_sep (fun () -> str ",") (pr_constr env) l - | None -> spc () ++ str "by *" - -let pr_justification_method env = function - None -> mt () - | Some tac -> - spc () ++ str "using" ++ spc () ++ pr_tac env tac - -let pr_statement pr_it env st = - pr_label st.st_label ++ pr_it env st.st_it - -let pr_or_thesis pr_this env = function - Thesis Plain -> str "thesis" - | Thesis (For id) -> - str "thesis" ++ spc() ++ str "for" ++ spc () ++ pr_id id - | This c -> pr_this env c - -let pr_cut pr_it env c = - hov 1 (pr_it env c.cut_stat) ++ - pr_justification_items env c.cut_by ++ - pr_justification_method env c.cut_using - -let type_or_thesis = function - Thesis _ -> Term.mkProp - | This c -> c - -let _I x = x - -let rec print_hyps pconstr gtyp env sep _be _have hyps = - let pr_sep = if sep then str "and" ++ spc () else mt () in - match hyps with - (Hvar _ ::_) as rest -> - spc () ++ pr_sep ++ str _have ++ - print_vars pconstr gtyp env false _be _have rest - | Hprop st :: rest -> - begin - let nenv = - match st.st_label with - Anonymous -> env - | Name id -> Environ.push_named (id,None,gtyp st.st_it) env in - spc() ++ pr_sep ++ pr_statement pconstr env st ++ - print_hyps pconstr gtyp nenv true _be _have rest - end - | [] -> mt () - -and print_vars pconstr gtyp env sep _be _have vars = - match vars with - Hvar st :: rest -> - begin - let nenv = - match st.st_label with - Anonymous -> anomaly "anonymous variable" - | Name id -> Environ.push_named (id,None,st.st_it) env in - let pr_sep = if sep then pr_coma () else mt () in - spc() ++ pr_sep ++ - pr_statement pr_constr env st ++ - print_vars pconstr gtyp nenv true _be _have rest - end - | (Hprop _ :: _) as rest -> - let _st = if _be then - str "be such that" - else - str "such that" in - spc() ++ _st ++ print_hyps pconstr gtyp env false _be _have rest - | [] -> mt () - -let pr_suffices_clause env (hyps,c) = - print_hyps pr_constr _I env false false "to have" hyps ++ spc () ++ - str "to show" ++ spc () ++ pr_or_thesis pr_constr env c - -let pr_elim_type = function - ET_Case_analysis -> str "cases" - | ET_Induction -> str "induction" - -let pr_casee env =function - Real c -> str "on" ++ spc () ++ pr_constr env c - | Virtual cut -> str "of" ++ spc () ++ pr_cut (pr_statement pr_constr) env cut - -let pr_side = function - Lhs -> str "=~" - | Rhs -> str "~=" - -let rec pr_bare_proof_instr _then _thus env = function - | Pescape -> str "escape" - | Pthen i -> pr_bare_proof_instr true _thus env i - | Pthus i -> pr_bare_proof_instr _then true env i - | Phence i -> pr_bare_proof_instr true true env i - | Pcut c -> - begin - match _then,_thus with - false,false -> str "have" ++ spc () ++ - pr_cut (pr_statement (pr_or_thesis pr_constr)) env c - | false,true -> str "thus" ++ spc () ++ - pr_cut (pr_statement (pr_or_thesis pr_constr)) env c - | true,false -> str "then" ++ spc () ++ - pr_cut (pr_statement (pr_or_thesis pr_constr)) env c - | true,true -> str "hence" ++ spc () ++ - pr_cut (pr_statement (pr_or_thesis pr_constr)) env c - end - | Psuffices c -> - str "suffices" ++ pr_cut pr_suffices_clause env c - | Prew (sid,c) -> - (if _thus then str "thus" else str " ") ++ spc () ++ - pr_side sid ++ spc () ++ pr_cut (pr_statement pr_constr) env c - | Passume hyps -> - str "assume" ++ print_hyps pr_constr _I env false false "we have" hyps - | Plet hyps -> - str "let" ++ print_vars pr_constr _I env false true "let" hyps - | Pclaim st -> - str "claim" ++ spc () ++ pr_statement pr_constr env st - | Pfocus st -> - str "focus on" ++ spc () ++ pr_statement pr_constr env st - | Pconsider (id,hyps) -> - str "consider" ++ print_vars pr_constr _I env false false "consider" hyps - ++ spc () ++ str "from " ++ pr_constr env id - | Pgiven hyps -> - str "given" ++ print_vars pr_constr _I env false false "given" hyps - | Ptake witl -> - str "take" ++ spc () ++ - prlist_with_sep pr_coma (pr_constr env) witl - | Pdefine (id,args,body) -> - str "define" ++ spc () ++ pr_id id ++ spc () ++ - prlist_with_sep spc - (fun st -> str "(" ++ - pr_statement pr_constr env st ++ str ")") args ++ spc () ++ - str "as" ++ (pr_constr env body) - | Pcast (id,typ) -> - str "reconsider" ++ spc () ++ - pr_or_thesis (fun _ -> pr_id) env id ++ spc () ++ - str "as" ++ spc () ++ (pr_constr env typ) - | Psuppose hyps -> - str "suppose" ++ - print_hyps pr_constr _I env false false "we have" hyps - | Pcase (params,pat,hyps) -> - str "suppose it is" ++ spc () ++ pr_pat pat ++ - (if params = [] then mt () else - (spc () ++ str "with" ++ spc () ++ - prlist_with_sep spc - (fun st -> str "(" ++ - pr_statement pr_constr env st ++ str ")") params ++ spc ())) - ++ - (if hyps = [] then mt () else - (spc () ++ str "and" ++ - print_hyps (pr_or_thesis pr_constr) type_or_thesis - env false false "we have" hyps)) - | Pper (et,c) -> - str "per" ++ spc () ++ pr_elim_type et ++ spc () ++ - pr_casee env c - | Pend (B_elim et) -> str "end" ++ spc () ++ pr_elim_type et - | _ -> anomaly "unprintable instruction" - -let pr_emph = function - 0 -> str " " - | 1 -> str "* " - | 2 -> str "** " - | 3 -> str "*** " - | _ -> anomaly "unknown emphasis" - -let pr_proof_instr env instr = - pr_emph instr.emph ++ spc () ++ - pr_bare_proof_instr false false env instr.instr - diff --git a/parsing/ppdecl_proof.mli b/parsing/ppdecl_proof.mli deleted file mode 100644 index fd6fb66376..0000000000 --- a/parsing/ppdecl_proof.mli +++ /dev/null @@ -1,2 +0,0 @@ - -val pr_proof_instr : Environ.env -> Decl_expr.proof_instr -> Pp.std_ppcmds diff --git a/parsing/ppvernac.ml b/parsing/ppvernac.ml index 9ebf77adba..dc61aaa261 100644 --- a/parsing/ppvernac.ml +++ b/parsing/ppvernac.ml @@ -774,23 +774,16 @@ let rec pr_vernac = function hov 2 (str"Include " ++ prlist_with_sep (fun () -> str " <+ ") pr_m mexprs) (* Solving *) - | VernacSolve (i,tac,deftac) -> + | VernacSolve (i,b,tac,deftac) -> (if i = 1 then mt() else int i ++ str ": ") ++ + (match b with None -> mt () | Some Dash -> str"-" | Some Star -> str"*" | Some Plus -> str"+") ++ pr_raw_tactic tac - ++ (try if deftac & Pfedit.get_end_tac() <> None then str ".." else mt () + ++ (try if deftac then str ".." else mt () with UserError _|Stdpp.Exc_located _ -> mt()) | VernacSolveExistential (i,c) -> str"Existential " ++ int i ++ pr_lconstrarg c - (* MMode *) - - | VernacProofInstr instr -> anomaly "Not implemented" - | VernacDeclProof -> str "proof" - | VernacReturn -> str "return" - - (* /MMode *) - (* Auxiliary file and library management *) | VernacRequireFrom (exp,spe,f) -> hov 2 (str"Require" ++ spc() ++ pr_require_token exp ++ diff --git a/parsing/printer.ml b/parsing/printer.ml index d9dced7916..cd07c4e15c 100644 --- a/parsing/printer.ml +++ b/parsing/printer.ml @@ -22,13 +22,14 @@ open Libnames open Nametab open Evd open Proof_type -open Decl_mode open Refiner open Pfedit open Ppconstr open Constrextern open Tacexpr +open Store.Field + let emacs_str s alts = match !Flags.print_emacs, !Flags.print_emacs_safechar with | true, true -> alts @@ -265,18 +266,13 @@ let pr_subgoal_metas metas env= hv 0 (prlist_with_sep mt pr_one metas) (* display complete goal *) -let default_pr_goal g = - let env = evar_unfiltered_env g in +let default_pr_goal gs = + let (g,sigma) = Goal.V82.nf_evar (project gs) (sig_it gs) in + let env = Goal.V82.unfiltered_env sigma g in let preamb,thesis,penv,pc = - if g.evar_extra = None then - mt (), mt (), - pr_context_of env, - pr_ltype_env_at_top env g.evar_concl - else - (str " *** Declarative Mode ***" ++ fnl ()++fnl ()), - (str "thesis := " ++ fnl ()), - pr_context_of env, - pr_ltype_env_at_top env g.evar_concl + mt (), mt (), + pr_context_of env, + pr_ltype_env_at_top env (Goal.V82.concl sigma g) in preamb ++ str" " ++ hv 0 (penv ++ fnl () ++ @@ -285,9 +281,10 @@ let default_pr_goal g = thesis ++ str " " ++ pc) ++ fnl () (* display the conclusion of a goal *) -let pr_concl n g = - let env = evar_env g in - let pc = pr_ltype_env_at_top env g.evar_concl in +let pr_concl n sigma g = + let (g,sigma) = Goal.V82.nf_evar sigma g in + let env = Goal.V82.env sigma g in + let pc = pr_ltype_env_at_top env (Goal.V82.concl sigma g) in str (emacs_str (String.make 1 (Char.chr 253)) "") ++ str "subgoal " ++ int n ++ str " is:" ++ cut () ++ str" " ++ pc @@ -313,12 +310,12 @@ let rec pr_evars_int i = function str (string_of_existential ev) ++ str " : " ++ pegl)) ++ fnl () ++ pei -let default_pr_subgoal n = +let default_pr_subgoal n sigma = let rec prrec p = function | [] -> error "No such goal." | g::rest -> if p = 1 then - let pg = default_pr_goal g in + let pg = default_pr_goal { sigma=sigma ; it=g } in v 0 (str "subgoal " ++ int n ++ str " is:" ++ cut () ++ pg) else prrec (p-1) rest @@ -343,17 +340,17 @@ let default_pr_subgoals close_cmd sigma = function str "variables:" ++ fnl () ++ (hov 0 pei)) end | [g] -> - let pg = default_pr_goal g in + let pg = default_pr_goal { it = g ; sigma = sigma } in v 0 (str ("1 "^"subgoal") ++cut () ++ pg) | g1::rest -> let rec pr_rec n = function | [] -> (mt ()) | g::rest -> - let pc = pr_concl n g in + let pc = pr_concl n sigma g in let prest = pr_rec (n+1) rest in (cut () ++ pc ++ prest) in - let pg1 = default_pr_goal g1 in + let pg1 = default_pr_goal { it = g1 ; sigma = sigma } in let prest = pr_rec 2 rest in v 0 (int(List.length rest+1) ++ str" subgoals" ++ cut () ++ pg1 ++ prest ++ fnl ()) @@ -365,8 +362,8 @@ let default_pr_subgoals close_cmd sigma = function type printer_pr = { pr_subgoals : string option -> evar_map -> goal list -> std_ppcmds; - pr_subgoal : int -> goal list -> std_ppcmds; - pr_goal : goal -> std_ppcmds; + pr_subgoal : int -> evar_map -> goal list -> std_ppcmds; + pr_goal : goal sigma -> std_ppcmds; } let default_printer_pr = { @@ -387,25 +384,29 @@ let pr_goal x = !printer_pr.pr_goal x (**********************************************************************) let pr_open_subgoals () = - let pfts = get_pftreestate () in - let gls = fst (frontier (proof_of_pftreestate pfts)) in - match focus() with - | 0 -> - let sigma = (top_goal_of_pftreestate pfts).sigma in - let close_cmd = Decl_mode.get_end_command pfts in - pr_subgoals close_cmd sigma gls - | n -> - assert (n > List.length gls); - if List.length gls < 2 then - pr_subgoal n gls - else - (* LEM TODO: this way of saying how many subgoals has to be abstracted out*) - v 0 (int(List.length gls) ++ str" subgoals" ++ cut () ++ - pr_subgoal n gls) + let p = Proof_global.give_me_the_proof () in + let { Evd.it = goals ; sigma = sigma } = Proof.V82.subgoals p in + begin match goals with + | [] -> let { Evd.it = bgoals ; sigma = bsigma } = Proof.V82.background_subgoals p in + begin match bgoals with + | [] -> pr_subgoals None sigma goals + | _ -> pr_subgoals None bsigma bgoals ++ fnl () ++ fnl () ++ + str"This subproof is complete, but there are still unfocused goals:" + (* spiwack: to stay compatible with the proof general and coqide, + I use print the message after the goal. It would be better to have + something like: + str"This subproof is complete, but there are still unfocused goals:" + ++ fnl () ++ fnl () ++ pr_subgoals None bsigma bgoals + instead. But it doesn't quite work. + *) + end + | _ -> pr_subgoals None sigma goals + end let pr_nth_open_subgoal n = - let pf = proof_of_pftreestate (get_pftreestate ()) in - pr_subgoal n (fst (frontier pf)) + let pf = get_pftreestate () in + let { it=gls ; sigma=sigma } = Proof.V82.subgoals pf in + pr_subgoal n sigma gls (* Elementary tactics *) diff --git a/parsing/printer.mli b/parsing/printer.mli index 1797eaf22b..2c1586abf7 100644 --- a/parsing/printer.mli +++ b/parsing/printer.mli @@ -101,9 +101,9 @@ val pr_transparent_state : transparent_state -> std_ppcmds (* Proofs *) -val pr_goal : goal -> std_ppcmds +val pr_goal : goal sigma -> std_ppcmds val pr_subgoals : string option -> evar_map -> goal list -> std_ppcmds -val pr_subgoal : int -> goal list -> std_ppcmds +val pr_subgoal : int -> evar_map -> goal list -> std_ppcmds val pr_open_subgoals : unit -> std_ppcmds val pr_nth_open_subgoal : int -> std_ppcmds @@ -130,8 +130,8 @@ val pr_assumptionset : env -> Term.types Environ.ContextObjectMap.t ->std_ppcmds type printer_pr = { pr_subgoals : string option -> evar_map -> goal list -> std_ppcmds; - pr_subgoal : int -> goal list -> std_ppcmds; - pr_goal : goal -> std_ppcmds; + pr_subgoal : int -> evar_map -> goal list -> std_ppcmds; + pr_goal : goal sigma -> std_ppcmds; };; val set_printer_pr : printer_pr -> unit diff --git a/parsing/tactic_printer.ml b/parsing/tactic_printer.ml index c09b3431e5..bf554acf69 100644 --- a/parsing/tactic_printer.ml +++ b/parsing/tactic_printer.ml @@ -14,8 +14,6 @@ open Sign open Evd open Tacexpr open Proof_type -open Proof_trees -open Decl_expr open Logic open Printer @@ -26,16 +24,12 @@ let pr_tactic = function | t -> Pptactic.pr_tactic (Global.env()) t -let pr_proof_instr instr = - Ppdecl_proof.pr_proof_instr (Global.env()) instr - let pr_rule = function | Prim r -> hov 0 (pr_prim_rule r) | Nested(cmpd,_) -> begin match cmpd with | Tactic (texp,_) -> hov 0 (pr_tactic texp) - | Proof_instr (_,instr) -> hov 0 (pr_proof_instr instr) end | Daimon -> str "" | Decl_proof _ -> str "proof" @@ -62,33 +56,23 @@ let pr_rule_dot_fnl = function exception Different -(* We remove from the var context of env what is already in osign *) -let thin_sign osign sign = - Sign.fold_named_context - (fun (id,c,ty as d) sign -> - try - if Sign.lookup_named id osign = (id,c,ty) then sign - else raise Different - with Not_found | Different -> Environ.push_named_context_val d sign) - sign ~init:Environ.empty_named_context_val - -let rec print_proof _sigma osign pf = - let hyps = Environ.named_context_of_val pf.goal.evar_hyps in - let hyps' = thin_sign osign hyps in +let rec print_proof sigma osign pf = + (* spiwack: [osign] is currently ignored, not sure if this function is even used. *) + let hyps = Environ.named_context_of_val (Goal.V82.hyps sigma pf.goal) in match pf.ref with | None -> - hov 0 (pr_goal {pf.goal with evar_hyps=hyps'}) + hov 0 (pr_goal {sigma = sigma; it=pf.goal }) | Some(r,spfl) -> hov 0 - (hov 0 (pr_goal {pf.goal with evar_hyps=hyps'}) ++ + (hov 0 (pr_goal {sigma = sigma; it=pf.goal }) ++ spc () ++ str" BY " ++ hov 0 (pr_rule r) ++ fnl () ++ str" " ++ - hov 0 (prlist_with_sep pr_fnl (print_proof _sigma hyps) spfl)) + hov 0 (prlist_with_sep pr_fnl (print_proof sigma hyps) spfl)) -let pr_change gl = +let pr_change sigma gl = str"change " ++ - pr_lconstr_env (Global.env_of_context gl.evar_hyps) gl.evar_concl ++ str"." + pr_lconstr_env (Goal.V82.env sigma gl) (Goal.V82.concl sigma gl) ++ str"." let print_decl_script tac_printer ?(nochange=true) sigma pf = let rec print_prf pf = @@ -97,36 +81,10 @@ let print_decl_script tac_printer ?(nochange=true) sigma pf = (if nochange then (str"") else - pr_change pf.goal) + pr_change sigma pf.goal) ++ fnl () | Some (Daimon,[]) -> str "(* Some proof has been skipped here *)" | Some (Prim Change_evars,[subpf]) -> print_prf subpf - | Some (Nested(Proof_instr (opened,instr),_) as rule,subprfs) -> - begin - match instr.instr,subprfs with - Pescape,[{ref=Some(_,subsubprfs)}] -> - hov 7 - (pr_rule_dot_fnl rule ++ - prlist_with_sep pr_fnl tac_printer subsubprfs) ++ fnl () ++ - if opened then mt () else str "return." - | Pclaim _,[body;cont] -> - hov 2 (pr_rule_dot_fnl rule ++ print_prf body) ++ fnl () ++ - (if opened then mt () else str "end claim." ++ fnl ()) ++ - print_prf cont - | Pfocus _,[body;cont] -> - hov 2 (pr_rule_dot_fnl rule ++ print_prf body) ++ - fnl () ++ - (if opened then mt () else str "end focus." ++ fnl ()) ++ - print_prf cont - | (Psuppose _ |Pcase (_,_,_)),[body;cont] -> - hov 2 (pr_rule_dot_fnl rule ++ print_prf body) ++ fnl () ++ - print_prf cont - | _,[next] -> - pr_rule_dot_fnl rule ++ print_prf next - | _,[] -> - pr_rule_dot rule - | _,_ -> anomaly "unknown branching instruction" - end | _ -> anomaly "Not Applicable" in print_prf pf @@ -137,12 +95,12 @@ let print_script ?(nochange=true) sigma pf = (if nochange then (str"") else - pr_change pf.goal) + pr_change sigma pf.goal) ++ fnl () | Some(Decl_proof opened,script) -> assert (List.length script = 1); begin - if nochange then (mt ()) else (pr_change pf.goal ++ fnl ()) + if nochange then (mt ()) else (pr_change sigma pf.goal ++ fnl ()) end ++ begin hov 0 (str "proof." ++ fnl () ++ @@ -153,10 +111,10 @@ let print_script ?(nochange=true) sigma pf = if opened then mt () else (str "end proof." ++ fnl ()) end | Some(Daimon,spfl) -> - ((if nochange then (mt ()) else (pr_change pf.goal ++ fnl ())) ++ + ((if nochange then (mt ()) else (pr_change sigma pf.goal ++ fnl ())) ++ prlist_with_sep pr_fnl print_prf spfl ) | Some(rule,spfl) -> - ((if nochange then (mt ()) else (pr_change pf.goal ++ fnl ())) ++ + ((if nochange then (mt ()) else (pr_change sigma pf.goal ++ fnl ())) ++ pr_rule_dot_fnl rule ++ prlist_with_sep pr_fnl print_prf spfl ) in print_prf pf @@ -168,13 +126,12 @@ let print_treescript ?(nochange=true) sigma pf = match pf.ref with | None -> if nochange then - if pf.goal.evar_extra=None then str"" - else str"" - else pr_change pf.goal + str"" + else pr_change sigma pf.goal | Some(Decl_proof opened,script) -> assert (List.length script = 1); begin - if nochange then mt () else pr_change pf.goal ++ fnl () + if nochange then mt () else pr_change sigma pf.goal ++ fnl () end ++ hov 0 begin str "proof." ++ fnl () ++ @@ -184,16 +141,16 @@ let print_treescript ?(nochange=true) sigma pf = if opened then mt () else (str "end proof." ++ fnl ()) end | Some(Daimon,spfl) -> - (if nochange then mt () else pr_change pf.goal ++ fnl ()) ++ + (if nochange then mt () else pr_change sigma pf.goal ++ fnl ()) ++ prlist_with_sep pr_fnl (print_script ~nochange sigma) spfl | Some(r,spfl) -> let indent = if List.length spfl >= 2 then 1 else 0 in - (if nochange then mt () else pr_change pf.goal ++ fnl ()) ++ + (if nochange then mt () else pr_change sigma pf.goal ++ fnl ()) ++ hv indent (pr_rule_dot_fnl r ++ prlist_with_sep fnl print_prf spfl) in hov 0 (print_prf pf) let rec print_info_script sigma osign pf = - let {evar_hyps=sign; evar_concl=cl} = pf.goal in + let sign = Goal.V82.hyps sigma pf.goal in match pf.ref with | None -> (mt ()) | Some(r,spfl) -> @@ -214,12 +171,4 @@ let rec print_info_script sigma osign pf = let format_print_info_script sigma osign pf = hov 0 (print_info_script sigma osign pf) -let print_subscript sigma sign pf = - if is_tactic_proof pf then - format_print_info_script sigma sign (subproof_of_proof pf) - else - format_print_info_script sigma sign pf - -let _ = Refiner.set_info_printer print_subscript -let _ = Refiner.set_proof_printer print_proof diff --git a/parsing/tactic_printer.mli b/parsing/tactic_printer.mli index d46f19c64c..96cbeb9a84 100644 --- a/parsing/tactic_printer.mli +++ b/parsing/tactic_printer.mli @@ -21,7 +21,6 @@ open Proof_type val print_proof : evar_map -> named_context -> proof_tree -> std_ppcmds val pr_rule : rule -> std_ppcmds val pr_tactic : tactic_expr -> std_ppcmds -val pr_proof_instr : Decl_expr.proof_instr -> Pp.std_ppcmds val print_script : ?nochange:bool -> evar_map -> proof_tree -> std_ppcmds val print_treescript : diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4 index e8a3094b9a..e1997b878b 100644 --- a/parsing/vernacextend.ml4 +++ b/parsing/vernacextend.ml4 @@ -48,9 +48,10 @@ let make_clauses s l = let mlexpr_of_clause = mlexpr_of_list - (fun (a,b,c) -> mlexpr_of_list make_prod_item (GramTerminal a::b)) + (fun (a,b,c) -> mlexpr_of_list make_prod_item + (Option.List.cons (Option.map (fun a -> GramTerminal a) a) b)) -let declare_command loc s cl = +let declare_command loc s nt cl = let gl = mlexpr_of_clause cl in let icl = make_clauses s cl in <:str_item< @@ -59,7 +60,7 @@ let declare_command loc s cl = open Extrawit; try Vernacinterp.vinterp_add $mlexpr_of_string s$ (fun [ $list:icl$ ]) with e -> Pp.pp (Cerrors.explain_exn e); - Egrammar.extend_vernac_command_grammar $mlexpr_of_string s$ $gl$; + Egrammar.extend_vernac_command_grammar $mlexpr_of_string s$ $nt$ $gl$; end >> @@ -71,13 +72,22 @@ EXTEND [ [ "VERNAC"; "COMMAND"; "EXTEND"; s = UIDENT; OPT "|"; l = LIST1 rule SEP "|"; "END" -> - declare_command loc s l ] ] + declare_command loc s <:expr> l + | "VERNAC"; nt = LIDENT ; "EXTEND"; s = UIDENT; + OPT "|"; l = LIST1 rule SEP "|"; + "END" -> + declare_command loc s <:expr> l ] ] ; + (* spiwack: comment-by-guessing: it seems that the isolated string (which + otherwise could have been another argument) is not passed to the + VernacExtend interpreter function to discriminate between the clauses. *) rule: [ [ "["; s = STRING; l = LIST0 args; "]"; "->"; "["; e = Pcaml.expr; "]" -> if s = "" then Util.user_err_loc (loc,"",Pp.str"Command name is empty."); - (s,l,<:expr< fun () -> $e$ >>) + (Some s,l,<:expr< fun () -> $e$ >>) + | "[" ; "-" ; l = LIST1 args ; "]" ; "->" ; "[" ; e = Pcaml.expr ; "]" -> + (None,l,<:expr< fun () -> $e$ >>) ] ] ; args: diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 9cc6f9de93..9b5fca4da1 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -668,11 +668,11 @@ let __eps__ = id_of_string "_eps_" let new_state_var typ state = let id = pf_get_new_id __eps__ state.gls in - state.gls<- - {state.gls with it = - {state.gls.it with evar_hyps = - Environ.push_named_context_val (id,None,typ) - state.gls.it.evar_hyps}}; + let {it=gl ; sigma=sigma} = state.gls in + let new_hyps = + Environ.push_named_context_val (id,None,typ) (Goal.V82.hyps sigma gl) in + let gls = Goal.V82.new_goal_with sigma gl new_hyps in + state.gls<- gls; id let complete_one_class state i= diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 4e6ea8022e..ccfa2a0a70 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -204,9 +204,9 @@ let rec make_prb gls depth additionnal_terms = neg_hyps:=(cid,nh):: !neg_hyps | `Rule patts -> add_quant state id true patts | `Nrule patts -> add_quant state id false patts - end) (Environ.named_context_of_val gls.it.evar_hyps); + end) (Environ.named_context_of_val (Goal.V82.hyps gls.sigma gls.it)); begin - match atom_of_constr env sigma gls.it.evar_concl with + match atom_of_constr env sigma (pf_concl gls) with `Eq (t,a,b) -> add_disequality state Goal a b | `Other g -> List.iter diff --git a/plugins/decl_mode/decl_expr.mli b/plugins/decl_mode/decl_expr.mli new file mode 100644 index 0000000000..20a95dabff --- /dev/null +++ b/plugins/decl_mode/decl_expr.mli @@ -0,0 +1,105 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Thesis n + | This c -> This (intern_constr globs c) + +let add_var id globs= + let l1,l2=globs.ltacvars in + {globs with ltacvars= (id::l1),(id::l2)} + +let add_name nam globs= + match nam with + Anonymous -> globs + | Name id -> add_var id globs + +let intern_hyp iconstr globs = function + Hvar (loc,(id,topt)) -> add_var id globs, + Hvar (loc,(id,Option.map (intern_constr globs) topt)) + | Hprop st -> add_name st.st_label globs, + Hprop (intern_statement iconstr globs st) + +let intern_hyps iconstr globs hyps = + snd (list_fold_map (intern_hyp iconstr) globs hyps) + +let intern_cut intern_it globs cut= + let nglobs,nstat=intern_it globs cut.cut_stat in + {cut_stat=nstat; + cut_by=intern_justification_items nglobs cut.cut_by; + cut_using=intern_justification_method nglobs cut.cut_using} + +let intern_casee globs = function + Real c -> Real (intern_constr globs c) + | Virtual cut -> Virtual + (intern_cut (intern_no_bind (intern_statement intern_constr)) globs cut) + +let intern_hyp_list args globs = + let intern_one globs (loc,(id,opttyp)) = + (add_var id globs), + (loc,(id,Option.map (intern_constr globs) opttyp)) in + list_fold_map intern_one globs args + +let intern_suffices_clause globs (hyps,c) = + let nglobs,nhyps = list_fold_map (intern_hyp intern_constr) globs hyps in + nglobs,(nhyps,intern_constr_or_thesis nglobs c) + +let intern_fundecl args body globs= + let nglobs,nargs = intern_hyp_list args globs in + nargs,intern_constr nglobs body + +let rec add_vars_of_simple_pattern globs = function + CPatAlias (loc,p,id) -> + add_vars_of_simple_pattern (add_var id globs) p +(* Stdpp.raise_with_loc loc + (UserError ("simple_pattern",str "\"as\" is not allowed here"))*) + | CPatOr (loc, _)-> + Stdpp.raise_with_loc loc + (UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here")) + | CPatDelimiters (_,_,p) -> + add_vars_of_simple_pattern globs p + | CPatCstr (_,_,pl) -> + List.fold_left add_vars_of_simple_pattern globs pl + | CPatNotation(_,_,(pl,pll)) -> + List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pll)) + | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs + | _ -> globs + +let rec intern_bare_proof_instr globs = function + Pthus i -> Pthus (intern_bare_proof_instr globs i) + | Pthen i -> Pthen (intern_bare_proof_instr globs i) + | Phence i -> Phence (intern_bare_proof_instr globs i) + | Pcut c -> Pcut + (intern_cut + (intern_no_bind (intern_statement intern_constr_or_thesis)) globs c) + | Psuffices c -> + Psuffices (intern_cut intern_suffices_clause globs c) + | Prew (s,c) -> Prew + (s,intern_cut + (intern_no_bind (intern_statement intern_constr)) globs c) + | Psuppose hyps -> Psuppose (intern_hyps intern_constr globs hyps) + | Pcase (params,pat,hyps) -> + let nglobs,nparams = intern_hyp_list params globs in + let nnglobs= add_vars_of_simple_pattern nglobs pat in + let nhyps = intern_hyps intern_constr_or_thesis nnglobs hyps in + Pcase (nparams,pat,nhyps) + | Ptake witl -> Ptake (List.map (intern_constr globs) witl) + | Pconsider (c,hyps) -> Pconsider (intern_constr globs c, + intern_hyps intern_constr globs hyps) + | Pper (et,c) -> Pper (et,intern_casee globs c) + | Pend bt -> Pend bt + | Pescape -> Pescape + | Passume hyps -> Passume (intern_hyps intern_constr globs hyps) + | Pgiven hyps -> Pgiven (intern_hyps intern_constr globs hyps) + | Plet hyps -> Plet (intern_hyps intern_constr globs hyps) + | Pclaim st -> Pclaim (intern_statement intern_constr globs st) + | Pfocus st -> Pfocus (intern_statement intern_constr globs st) + | Pdefine (id,args,body) -> + let nargs,nbody = intern_fundecl args body globs in + Pdefine (id,nargs,nbody) + | Pcast (id,typ) -> + Pcast (id,intern_constr globs typ) + +let rec intern_proof_instr globs instr= + {emph = instr.emph; + instr = intern_bare_proof_instr globs instr.instr} + +(* INTERP *) + +let interp_justification_items sigma env = + Option.map (List.map (fun c ->understand sigma env (fst c))) + +let interp_constr check_sort sigma env c = + if check_sort then + understand_type sigma env (fst c) + else + understand sigma env (fst c) + +let special_whd env = + let infos=Closure.create_clos_infos Closure.betadeltaiota env in + (fun t -> Closure.whd_val infos (Closure.inject t)) + +let _eq = Libnames.constr_of_global (Coqlib.glob_eq) + +let decompose_eq env id = + let typ = Environ.named_type id env in + let whd = special_whd env typ in + match kind_of_term whd with + App (f,args)-> + if eq_constr f _eq && (Array.length args)=3 + then args.(0) + else error "Previous step is not an equality." + | _ -> error "Previous step is not an equality." + +let get_eq_typ info env = + let typ = decompose_eq env (get_last env) in + typ + +let interp_constr_in_type typ sigma env c = + understand sigma env (fst c) ~expected_type:typ + +let interp_statement interp_it sigma env st = + {st_label=st.st_label; + st_it=interp_it sigma env st.st_it} + +let interp_constr_or_thesis check_sort sigma env = function + Thesis n -> Thesis n + | This c -> This (interp_constr check_sort sigma env c) + +let abstract_one_hyp inject h raw = + match h with + Hvar (loc,(id,None)) -> + RProd (dummy_loc,Name id, Explicit, RHole (loc,Evd.BinderType (Name id)), raw) + | Hvar (loc,(id,Some typ)) -> + RProd (dummy_loc,Name id, Explicit, fst typ, raw) + | Hprop st -> + RProd (dummy_loc,st.st_label, Explicit, inject st.st_it, raw) + +let rawconstr_of_hyps inject hyps head = + List.fold_right (abstract_one_hyp inject) hyps head + +let raw_prop = RSort (dummy_loc,RProp Null) + +let rec match_hyps blend names constr = function + [] -> [],substl names constr + | hyp::q -> + let (name,typ,body)=destProd constr in + let st= {st_label=name;st_it=substl names typ} in + let qnames= + match name with + Anonymous -> mkMeta 0 :: names + | Name id -> mkVar id :: names in + let qhyp = match hyp with + Hprop st' -> Hprop (blend st st') + | Hvar _ -> Hvar st in + let rhyps,head = match_hyps blend qnames body q in + qhyp::rhyps,head + +let interp_hyps_gen inject blend sigma env hyps head = + let constr=understand sigma env (rawconstr_of_hyps inject hyps head) in + match_hyps blend [] constr hyps + +let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma env hyps raw_prop) + +let dummy_prefix= id_of_string "__" + +let rec deanonymize ids = + function + PatVar (loc,Anonymous) -> + let (found,known) = !ids in + let new_id=Namegen.next_ident_away dummy_prefix known in + let _= ids:= (loc,new_id) :: found , new_id :: known in + PatVar (loc,Name new_id) + | PatVar (loc,Name id) as pat -> + let (found,known) = !ids in + let _= ids:= (loc,id) :: found , known in + pat + | PatCstr(loc,cstr,lpat,nam) -> + PatCstr(loc,cstr,List.map (deanonymize ids) lpat,nam) + +let rec raw_of_pat = + function + PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable" + | PatVar (loc,Name id) -> + RVar (loc,id) + | PatCstr(loc,((ind,_) as cstr),lpat,_) -> + let mind= fst (Global.lookup_inductive ind) in + let rec add_params n q = + if n<=0 then q else + add_params (pred n) (RHole(dummy_loc, + Evd.TomatchTypeParameter(ind,n))::q) in + let args = List.map raw_of_pat lpat in + raw_app(loc,RRef(dummy_loc,Libnames.ConstructRef cstr), + add_params mind.Declarations.mind_nparams args) + +let prod_one_hyp = function + (loc,(id,None)) -> + (fun raw -> + RProd (dummy_loc,Name id, Explicit, + RHole (loc,Evd.BinderType (Name id)), raw)) + | (loc,(id,Some typ)) -> + (fun raw -> + RProd (dummy_loc,Name id, Explicit, fst typ, raw)) + +let prod_one_id (loc,id) raw = + RProd (dummy_loc,Name id, Explicit, + RHole (loc,Evd.BinderType (Name id)), raw) + +let let_in_one_alias (id,pat) raw = + RLetIn (dummy_loc,Name id, raw_of_pat pat, raw) + +let rec bind_primary_aliases map pat = + match pat with + PatVar (_,_) -> map + | PatCstr(loc,_,lpat,nam) -> + let map1 = + match nam with + Anonymous -> map + | Name id -> (id,pat)::map + in + List.fold_left bind_primary_aliases map1 lpat + +let bind_secondary_aliases map subst = + List.fold_left (fun map (ids,idp) -> (ids,List.assoc idp map)::map) map subst + +let bind_aliases patvars subst patt = + let map = bind_primary_aliases [] patt in + let map1 = bind_secondary_aliases map subst in + List.rev map1 + +let interp_pattern env pat_expr = + let patvars,pats = Constrintern.intern_pattern env pat_expr in + match pats with + [] -> anomaly "empty pattern list" + | [subst,patt] -> + (patvars,bind_aliases patvars subst patt,patt) + | _ -> anomaly "undetected disjunctive pattern" + +let rec match_args dest names constr = function + [] -> [],names,substl names constr + | _::q -> + let (name,typ,body)=dest constr in + let st={st_label=name;st_it=substl names typ} in + let qnames= + match name with + Anonymous -> assert false + | Name id -> mkVar id :: names in + let args,bnames,body = match_args dest qnames body q in + st::args,bnames,body + +let rec match_aliases names constr = function + [] -> [],names,substl names constr + | _::q -> + let (name,c,typ,body)=destLetIn constr in + let st={st_label=name;st_it=(substl names c,substl names typ)} in + let qnames= + match name with + Anonymous -> assert false + | Name id -> mkVar id :: names in + let args,bnames,body = match_aliases qnames body q in + st::args,bnames,body + +let detype_ground c = Detyping.detype false [] [] c + +let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = + let et,pinfo = + match info.pm_stack with + Per(et,pi,_,_)::_ -> et,pi + | _ -> error "No proof per cases/induction/inversion in progress." in + let mib,oib=Global.lookup_inductive pinfo.per_ind in + let num_params = pinfo.per_nparams in + let _ = + let expected = mib.Declarations.mind_nparams - num_params in + if List.length params <> expected then + errorlabstrm "suppose it is" + (str "Wrong number of extra arguments: " ++ + (if expected = 0 then str "none" else int expected) ++ spc () ++ + str "expected.") in + let app_ind = + let rind = RRef (dummy_loc,Libnames.IndRef pinfo.per_ind) in + let rparams = List.map detype_ground pinfo.per_params in + let rparams_rec = + List.map + (fun (loc,(id,_)) -> + RVar (loc,id)) params in + let dum_args= + list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark (Evd.Define false))) + oib.Declarations.mind_nrealargs in + raw_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in + let pat_vars,aliases,patt = interp_pattern env pat in + let inject = function + Thesis (Plain) -> Rawterm.RSort(dummy_loc,RProp Null) + | Thesis (For rec_occ) -> + if not (List.mem rec_occ pat_vars) then + errorlabstrm "suppose it is" + (str "Variable " ++ Nameops.pr_id rec_occ ++ + str " does not occur in pattern."); + Rawterm.RSort(dummy_loc,RProp Null) + | This (c,_) -> c in + let term1 = rawconstr_of_hyps inject hyps raw_prop in + let loc_ids,npatt = + let rids=ref ([],pat_vars) in + let npatt= deanonymize rids patt in + List.rev (fst !rids),npatt in + let term2 = + RLetIn(dummy_loc,Anonymous, + RCast(dummy_loc,raw_of_pat npatt, + CastConv (DEFAULTcast,app_ind)),term1) in + let term3=List.fold_right let_in_one_alias aliases term2 in + let term4=List.fold_right prod_one_id loc_ids term3 in + let term5=List.fold_right prod_one_hyp params term4 in + let constr = understand sigma env term5 in + let tparams,nam4,rest4 = match_args destProd [] constr params in + let tpatvars,nam3,rest3 = match_args destProd nam4 rest4 loc_ids in + let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in + let (_,pat_pat,pat_typ,rest1) = destLetIn rest2 in + let blend st st' = + match st'.st_it with + Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label} + | This _ -> {st_it = This st.st_it;st_label=st.st_label} in + let thyps = fst (match_hyps blend nam2 (Termops.pop rest1) hyps) in + tparams,{pat_vars=tpatvars; + pat_aliases=taliases; + pat_constr=pat_pat; + pat_typ=pat_typ; + pat_pat=patt; + pat_expr=pat},thyps + +let interp_cut interp_it sigma env cut= + let nenv,nstat = interp_it sigma env cut.cut_stat in + {cut with + cut_stat=nstat; + cut_by=interp_justification_items sigma nenv cut.cut_by} + +let interp_no_bind interp_it sigma env x = + env,interp_it sigma env x + +let interp_suffices_clause sigma env (hyps,cot)= + let (locvars,_) as res = + match cot with + This (c,_) -> + let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) sigma env hyps c in + nhyps,This nc + | Thesis Plain as th -> interp_hyps sigma env hyps,th + | Thesis (For n) -> error "\"thesis for\" is not applicable here." in + let push_one hyp env0 = + match hyp with + (Hprop st | Hvar st) -> + match st.st_label with + Name id -> Environ.push_named (id,None,st.st_it) env0 + | _ -> env in + let nenv = List.fold_right push_one locvars env in + nenv,res + +let interp_casee sigma env = function + Real c -> Real (understand sigma env (fst c)) + | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut) + +let abstract_one_arg = function + (loc,(id,None)) -> + (fun raw -> + RLambda (dummy_loc,Name id, Explicit, + RHole (loc,Evd.BinderType (Name id)), raw)) + | (loc,(id,Some typ)) -> + (fun raw -> + RLambda (dummy_loc,Name id, Explicit, fst typ, raw)) + +let rawconstr_of_fun args body = + List.fold_right abstract_one_arg args (fst body) + +let interp_fun sigma env args body = + let constr=understand sigma env (rawconstr_of_fun args body) in + match_args destLambda [] constr args + +let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = function + Pthus i -> Pthus (interp_bare_proof_instr info sigma env i) + | Pthen i -> Pthen (interp_bare_proof_instr info sigma env i) + | Phence i -> Phence (interp_bare_proof_instr info sigma env i) + | Pcut c -> Pcut (interp_cut + (interp_no_bind (interp_statement + (interp_constr_or_thesis true))) + sigma env c) + | Psuffices c -> + Psuffices (interp_cut interp_suffices_clause sigma env c) + | Prew (s,c) -> Prew (s,interp_cut + (interp_no_bind (interp_statement + (interp_constr_in_type (get_eq_typ info env)))) + sigma env c) + + | Psuppose hyps -> Psuppose (interp_hyps sigma env hyps) + | Pcase (params,pat,hyps) -> + let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in + Pcase (tparams,tpat,thyps) + | Ptake witl -> + Ptake (List.map (fun c -> understand sigma env (fst c)) witl) + | Pconsider (c,hyps) -> Pconsider (interp_constr false sigma env c, + interp_hyps sigma env hyps) + | Pper (et,c) -> Pper (et,interp_casee sigma env c) + | Pend bt -> Pend bt + | Pescape -> Pescape + | Passume hyps -> Passume (interp_hyps sigma env hyps) + | Pgiven hyps -> Pgiven (interp_hyps sigma env hyps) + | Plet hyps -> Plet (interp_hyps sigma env hyps) + | Pclaim st -> Pclaim (interp_statement (interp_constr true) sigma env st) + | Pfocus st -> Pfocus (interp_statement (interp_constr true) sigma env st) + | Pdefine (id,args,body) -> + let nargs,_,nbody = interp_fun sigma env args body in + Pdefine (id,nargs,nbody) + | Pcast (id,typ) -> + Pcast(id,interp_constr true sigma env typ) + +let rec interp_proof_instr info sigma env instr= + {emph = instr.emph; + instr = interp_bare_proof_instr info sigma env instr.instr} + + + diff --git a/plugins/decl_mode/decl_interp.mli b/plugins/decl_mode/decl_interp.mli new file mode 100644 index 0000000000..bd0859382b --- /dev/null +++ b/plugins/decl_mode/decl_interp.mli @@ -0,0 +1,18 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* raw_proof_instr -> glob_proof_instr +val interp_proof_instr : Decl_mode.pm_info -> + Evd.evar_map -> Environ.env -> glob_proof_instr -> proof_instr diff --git a/plugins/decl_mode/decl_mode.ml b/plugins/decl_mode/decl_mode.ml new file mode 100644 index 0000000000..90b0085ffa --- /dev/null +++ b/plugins/decl_mode/decl_mode.ml @@ -0,0 +1,110 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Mode_none + +let check_not_proof_mode str = + if get_current_mode () = Mode_proof then + error str + +let get_info sigma gl= + match info.get (Goal.V82.extra sigma gl) with + | None -> invalid_arg "get_info" + | Some pm -> pm + +let try_get_info sigma gl = + info.get (Goal.V82.extra sigma gl) + +let get_stack pts = + let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in + let info = get_info sigma (List.hd goals) in + info.pm_stack + +let get_top_stack pts = + let { it = gl ; sigma = sigma } = Proof.V82.top_goal pts in + let info = get_info sigma gl in + info.pm_stack + +let get_last env = + try + let (id,_,_) = List.hd (Environ.named_context env) in id + with Invalid_argument _ -> error "no previous statement to use" + diff --git a/plugins/decl_mode/decl_mode.mli b/plugins/decl_mode/decl_mode.mli new file mode 100644 index 0000000000..fe485ce9b6 --- /dev/null +++ b/plugins/decl_mode/decl_mode.mli @@ -0,0 +1,74 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit +val clear_daimon_flag : unit -> unit +val get_daimon_flag : unit -> bool + +type command_mode = + Mode_tactic + | Mode_proof + | Mode_none + +val mode_of_pftreestate : Proof.proof -> command_mode + +val get_current_mode : unit -> command_mode + +val check_not_proof_mode : string -> unit + +type split_tree= + Skip_patt of Idset.t * split_tree + | Split_patt of Idset.t * inductive * + (bool array * (Idset.t * split_tree) option) array + | Close_patt of split_tree + | End_patt of (identifier * (int * int)) + +type elim_kind = + EK_dep of split_tree + | EK_nodep + | EK_unknown + +type recpath = int option*Declarations.wf_paths + +type per_info = + {per_casee:constr; + per_ctype:types; + per_ind:inductive; + per_pred:constr; + per_args:constr list; + per_params:constr list; + per_nparams:int; + per_wf:recpath} + +type stack_info = + Per of Decl_expr.elim_type * per_info * elim_kind * Names.identifier list + | Suppose_case + | Claim + | Focus_claim + +type pm_info = + {pm_stack : stack_info list } + +val info : pm_info Store.Field.t + +val get_info : Evd.evar_map -> Proof_type.goal -> pm_info + +val try_get_info : Evd.evar_map -> Proof_type.goal -> pm_info option + +val get_stack : Proof.proof -> stack_info list + +val get_top_stack : Proof.proof -> stack_info list + +val get_last: Environ.env -> identifier diff --git a/plugins/decl_mode/decl_mode_plugin.mllib b/plugins/decl_mode/decl_mode_plugin.mllib new file mode 100644 index 0000000000..dce989bbcd --- /dev/null +++ b/plugins/decl_mode/decl_mode_plugin.mllib @@ -0,0 +1,7 @@ +Decl_expr +Decl_mode +Decl_interp +Decl_proof_instr +Ppdecl_proof +G_decl_mode +Decl_mode_plugin_mod diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml new file mode 100644 index 0000000000..cd695f239d --- /dev/null +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -0,0 +1,1496 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (!strictness)),(fun b -> strictness:=b) + +let _ = + declare_bool_option + { optsync = true; + optname = "strict mode"; + optkey = ["Strict";"Proofs"]; + optread = get_strictness; + optwrite = set_strictness } + +let tcl_change_info_gen info_gen = + (fun gls -> + let concl = pf_concl gls in + let hyps = Goal.V82.hyps (project gls) (sig_it gls) in + let extra = Goal.V82.extra (project gls) (sig_it gls) in + let (gl,ev,sigma) = Goal.V82.mk_goal (project gls) hyps concl (info_gen extra) in + let sigma = Goal.V82.partial_solution sigma (sig_it gls) ev in + { it = [gl] ; sigma= sigma } ) + +open Store.Field + +let tcl_change_info info gls = + let info_gen = Decl_mode.info.set info in + tcl_change_info_gen info_gen gls + +let tcl_erase_info gls = tcl_change_info_gen (Decl_mode.info.remove) gls + +let special_whd gl= + let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in + (fun t -> Closure.whd_val infos (Closure.inject t)) + +let special_nf gl= + let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in + (fun t -> Closure.norm_val infos (Closure.inject t)) + +let is_good_inductive env ind = + let mib,oib = Inductive.lookup_mind_specif env ind in + oib.mind_nrealargs = 0 && not (Inductiveops.mis_is_recursive (ind,mib,oib)) + +let check_not_per pts = + if not (Proof.is_done pts) then + match get_stack pts with + Per (_,_,_,_)::_ -> + error "You are inside a proof per cases/induction.\n\ +Please \"suppose\" something or \"end\" it now." + | _ -> () + +let mk_evd metalist gls = + let evd0= create_goal_evar_defs (sig_sig gls) in + let add_one (meta,typ) evd = + meta_declare meta typ evd in + List.fold_right add_one metalist evd0 + +let is_tmp id = (string_of_id id).[0] = '_' + +let tmp_ids gls = + let ctx = pf_hyps gls in + match ctx with + [] -> [] + | _::q -> List.filter is_tmp (ids_of_named_context q) + +let clean_tmp gls = + let clean_id id0 gls0 = + tclTRY (clear [id0]) gls0 in + let rec clean_all = function + [] -> tclIDTAC + | id :: rest -> tclTHEN (clean_id id) (clean_all rest) + in + clean_all (tmp_ids gls) gls + +let assert_postpone id t = + assert_tac (Name id) t + +(* start a proof *) + +let proof_focus = Proof.new_focus_kind () +let proof_cond = Proof.no_cond proof_focus + +let start_proof_tac gls= + let info={pm_stack=[]} in + tcl_change_info info gls + +let go_to_proof_mode () = + Pfedit.by start_proof_tac ; + let p = Proof_global.give_me_the_proof () in + Proof.focus proof_cond 1 p + +(* closing gaps *) + +let daimon_tac gls = + set_daimon_flag (); + {it=[];sigma=sig_sig gls} + +let daimon _ pftree = + set_daimon_flag (); + {pftree with + open_subgoals=0; + ref=Some (Daimon,[])} + +let daimon_subtree = + fun _ -> Util.anomaly "Todo: Decl_proof_instr.daimon_subtree" + +(* marking closed blocks *) + +let rec is_focussing_instr = function + Pthus i | Pthen i | Phence i -> is_focussing_instr i + | Pescape | Pper _ | Pclaim _ | Pfocus _ + | Psuppose _ | Pcase (_,_,_) -> true + | _ -> false + +let mark_rule_as_done = function + Decl_proof true -> Decl_proof false + | Decl_proof false -> + anomaly "already marked as done" + | _ -> anomaly "mark_rule_as_done" + + +(* post-instruction focus management *) + +let goto_current_focus pts = + Proof.unfocus proof_focus pts + +let goto_current_focus_or_top pts = + try goto_current_focus pts + with Util.UserError _ -> () + +(* return *) + +let close_tactic_mode pts = + let pts1= + try goto_current_focus pts + with Not_found -> + error "\"return\" cannot be used outside of Declarative Proof Mode." in + let pts2 = daimon_subtree pts1 in + goto_current_focus pts2 + +let return_from_tactic_mode () = + Util.anomaly "Todo: Decl_proof_instr.return_from_tactic_mode" + +(* end proof/claim *) + +let close_block bt pts = + if Proof.no_focused_goal pts then + goto_current_focus pts + else + let stack =get_stack pts in + match bt,stack with + B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] -> + (goto_current_focus pts) + | _, Claim::_ -> + error "\"end claim\" expected." + | _, Focus_claim::_ -> + error "\"end focus\" expected." + | _, [] -> + error "\"end proof\" expected." + | _, (Per (et,_,_,_)::_|Suppose_case::Per (et,_,_,_)::_) -> + begin + match et with + ET_Case_analysis -> error "\"end cases\" expected." + | ET_Induction -> error "\"end induction\" expected." + end + | _,_ -> anomaly "Lonely suppose on stack." + + +(* utility for suppose / suppose it is *) + +let close_previous_case pts = + if + Proof.is_done pts + then + match get_top_stack pts with + Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..." + | Suppose_case :: Per (et,_,_,_) :: _ -> + goto_current_focus (pts) + | _ -> error "Not inside a proof per cases or induction." + else + match get_stack pts with + Per (et,_,_,_) :: _ -> () + | Suppose_case :: Per (et,_,_,_) :: _ -> + goto_current_focus ((pts)) + | _ -> error "Not inside a proof per cases or induction." + +(* Proof instructions *) + +(* automation *) + +let filter_hyps f gls = + let filter_aux (id,_,_) = + if f id then + tclIDTAC + else + tclTRY (clear [id]) in + tclMAP filter_aux (pf_hyps gls) gls + +let local_hyp_prefix = id_of_string "___" + +let add_justification_hyps keep items gls = + let add_aux c gls= + match kind_of_term c with + Var id -> + keep:=Idset.add id !keep; + tclIDTAC gls + | _ -> + let id=pf_get_new_id local_hyp_prefix gls in + keep:=Idset.add id !keep; + tclTHEN (letin_tac None (Names.Name id) c None Tacexpr.nowhere) + (thin_body [id]) gls in + tclMAP add_aux items gls + +let prepare_goal items gls = + let tokeep = ref Idset.empty in + let auxres = add_justification_hyps tokeep items gls in + tclTHENLIST + [ (fun _ -> auxres); + filter_hyps (let keep = !tokeep in fun id -> Idset.mem id keep)] gls + +let my_automation_tac = ref + (fun gls -> anomaly "No automation registered") + +let register_automation_tac tac = my_automation_tac:= tac + +let automation_tac gls = !my_automation_tac gls + +let justification tac gls= + tclORELSE + (tclSOLVE [tclTHEN tac assumption]) + (fun gls -> + if get_strictness () then + error "Insufficient justification." + else + begin + msg_warning (str "Insufficient justification."); + daimon_tac gls + end) gls + +let default_justification elems gls= + justification (tclTHEN (prepare_goal elems) automation_tac) gls + +(* code for conclusion refining *) + +let constant dir s = lazy (Coqlib.gen_constant "Declarative" dir s) + +let _and = constant ["Init";"Logic"] "and" + +let _and_rect = constant ["Init";"Logic"] "and_rect" + +let _prod = constant ["Init";"Datatypes"] "prod" + +let _prod_rect = constant ["Init";"Datatypes"] "prod_rect" + +let _ex = constant ["Init";"Logic"] "ex" + +let _ex_ind = constant ["Init";"Logic"] "ex_ind" + +let _sig = constant ["Init";"Specif"] "sig" + +let _sig_rect = constant ["Init";"Specif"] "sig_rect" + +let _sigT = constant ["Init";"Specif"] "sigT" + +let _sigT_rect = constant ["Init";"Specif"] "sigT_rect" + +type stackd_elt = +{se_meta:metavariable; + se_type:types; + se_last_meta:metavariable; + se_meta_list:(metavariable*types) list; + se_evd: evar_map} + +let rec replace_in_list m l = function + [] -> raise Not_found + | c::q -> if m=fst c then l@q else c::replace_in_list m l q + +let enstack_subsubgoals env se stack gls= + let hd,params = decompose_app (special_whd gls se.se_type) in + match kind_of_term hd with + Ind ind when is_good_inductive env ind -> + let mib,oib= + Inductive.lookup_mind_specif env ind in + let gentypes= + Inductive.arities_of_constructors ind (mib,oib) in + let process i gentyp = + let constructor = mkConstruct(ind,succ i) + (* constructors numbering*) in + let appterm = applist (constructor,params) in + let apptype = Term.prod_applist gentyp params in + let rc,_ = Reduction.dest_prod env apptype in + let rec meta_aux last lenv = function + [] -> (last,lenv,[]) + | (nam,_,typ)::q -> + let nlast=succ last in + let (llast,holes,metas) = + meta_aux nlast (mkMeta nlast :: lenv) q in + (llast,holes,(nlast,special_nf gls (substl lenv typ))::metas) in + let (nlast,holes,nmetas) = + meta_aux se.se_last_meta [] (List.rev rc) in + let refiner = applist (appterm,List.rev holes) in + let evd = meta_assign se.se_meta + (refiner,(ConvUpToEta 0,TypeProcessed (* ? *))) se.se_evd in + let ncreated = replace_in_list + se.se_meta nmetas se.se_meta_list in + let evd0 = List.fold_left + (fun evd (m,typ) -> meta_declare m typ evd) evd nmetas in + List.iter (fun (m,typ) -> + Stack.push + {se_meta=m; + se_type=typ; + se_evd=evd0; + se_meta_list=ncreated; + se_last_meta=nlast} stack) (List.rev nmetas) + in + Array.iteri process gentypes + | _ -> () + +let rec nf_list evd = + function + [] -> [] + | (m,typ)::others -> + if meta_defined evd m then + nf_list evd others + else + (m,nf_meta evd typ)::nf_list evd others + +let find_subsubgoal c ctyp skip submetas gls = + let env= pf_env gls in + let concl = pf_concl gls in + let evd = mk_evd ((0,concl)::submetas) gls in + let stack = Stack.create () in + let max_meta = + List.fold_left (fun a (m,_) -> max a m) 0 submetas in + let _ = Stack.push + {se_meta=0; + se_type=concl; + se_last_meta=max_meta; + se_meta_list=[0,concl]; + se_evd=evd} stack in + let rec dfs n = + let se = Stack.pop stack in + try + let unifier = + Unification.w_unify true env Reduction.CUMUL + ctyp se.se_type se.se_evd in + if n <= 0 then + {se with + se_evd=meta_assign se.se_meta + (c,(ConvUpToEta 0,TypeNotProcessed (* ?? *))) unifier; + se_meta_list=replace_in_list + se.se_meta submetas se.se_meta_list} + else + dfs (pred n) + with _ -> + begin + enstack_subsubgoals env se stack gls; + dfs n + end in + let nse= try dfs skip with Stack.Empty -> raise Not_found in + nf_list nse.se_evd nse.se_meta_list,nf_meta nse.se_evd (mkMeta 0) + +let concl_refiner metas body gls = + let concl = pf_concl gls in + let evd = sig_sig gls in + let env = pf_env gls in + let sort = family_of_sort (Typing.sort_of env evd concl) in + let rec aux env avoid subst = function + [] -> anomaly "concl_refiner: cannot happen" + | (n,typ)::rest -> + let _A = subst_meta subst typ in + let x = id_of_name_using_hdchar env _A Anonymous in + let _x = fresh_id avoid x gls in + let nenv = Environ.push_named (_x,None,_A) env in + let asort = family_of_sort (Typing.sort_of nenv evd _A) in + let nsubst = (n,mkVar _x)::subst in + if rest = [] then + asort,_A,mkNamedLambda _x _A (subst_meta nsubst body) + else + let bsort,_B,nbody = + aux nenv (_x::avoid) ((n,mkVar _x)::subst) rest in + let body = mkNamedLambda _x _A nbody in + if occur_term (mkVar _x) _B then + begin + let _P = mkNamedLambda _x _A _B in + match bsort,sort with + InProp,InProp -> + let _AxB = mkApp(Lazy.force _ex,[|_A;_P|]) in + InProp,_AxB, + mkApp(Lazy.force _ex_ind,[|_A;_P;concl;body|]) + | InProp,_ -> + let _AxB = mkApp(Lazy.force _sig,[|_A;_P|]) in + let _P0 = mkLambda(Anonymous,_AxB,concl) in + InType,_AxB, + mkApp(Lazy.force _sig_rect,[|_A;_P;_P0;body|]) + | _,_ -> + let _AxB = mkApp(Lazy.force _sigT,[|_A;_P|]) in + let _P0 = mkLambda(Anonymous,_AxB,concl) in + InType,_AxB, + mkApp(Lazy.force _sigT_rect,[|_A;_P;_P0;body|]) + end + else + begin + match asort,bsort with + InProp,InProp -> + let _AxB = mkApp(Lazy.force _and,[|_A;_B|]) in + InProp,_AxB, + mkApp(Lazy.force _and_rect,[|_A;_B;concl;body|]) + |_,_ -> + let _AxB = mkApp(Lazy.force _prod,[|_A;_B|]) in + let _P0 = mkLambda(Anonymous,_AxB,concl) in + InType,_AxB, + mkApp(Lazy.force _prod_rect,[|_A;_B;_P0;body|]) + end + in + let (_,_,prf) = aux env [] [] metas in + mkApp(prf,[|mkMeta 1|]) + +let thus_tac c ctyp submetas gls = + let list,proof = + try + find_subsubgoal c ctyp 0 submetas gls + with Not_found -> + error "I could not relate this statement to the thesis." in + if list = [] then + exact_check proof gls + else + let refiner = concl_refiner list proof gls in + Tactics.refine refiner gls + +(* general forward step *) + +let mk_stat_or_thesis info gls = function + This c -> c + | Thesis (For _ ) -> + error "\"thesis for ...\" is not applicable here." + | Thesis Plain -> pf_concl gls + +let just_tac _then cut info gls0 = + let items_tac gls = + match cut.cut_by with + None -> tclIDTAC gls + | Some items -> + let items_ = + if _then then + let last_id = get_last (pf_env gls) in + (mkVar last_id)::items + else items + in prepare_goal items_ gls in + let method_tac gls = + match cut.cut_using with + None -> + automation_tac gls + | Some tac -> + (Tacinterp.eval_tactic tac) gls in + justification (tclTHEN items_tac method_tac) gls0 + +let instr_cut mkstat _thus _then cut gls0 = + let info = get_its_info gls0 in + let stat = cut.cut_stat in + let (c_id,_) = match stat.st_label with + Anonymous -> + pf_get_new_id (id_of_string "_fact") gls0,false + | Name id -> id,true in + let c_stat = mkstat info gls0 stat.st_it in + let thus_tac gls= + if _thus then + thus_tac (mkVar c_id) c_stat [] gls + else tclIDTAC gls in + tclTHENS (assert_postpone c_id c_stat) + [tclTHEN tcl_erase_info (just_tac _then cut info); + thus_tac] gls0 + + + +(* iterated equality *) +let _eq = Libnames.constr_of_global (Coqlib.glob_eq) + +let decompose_eq id gls = + let typ = pf_get_hyp_typ gls id in + let whd = (special_whd gls typ) in + match kind_of_term whd with + App (f,args)-> + if eq_constr f _eq && (Array.length args)=3 + then (args.(0), + args.(1), + args.(2)) + else error "Previous step is not an equality." + | _ -> error "Previous step is not an equality." + +let instr_rew _thus rew_side cut gls0 = + let last_id = + try get_last (pf_env gls0) with _ -> error "No previous equality." in + let typ,lhs,rhs = decompose_eq last_id gls0 in + let items_tac gls = + match cut.cut_by with + None -> tclIDTAC gls + | Some items -> prepare_goal items gls in + let method_tac gls = + match cut.cut_using with + None -> + automation_tac gls + | Some tac -> + (Tacinterp.eval_tactic tac) gls in + let just_tac gls = + justification (tclTHEN items_tac method_tac) gls in + let (c_id,_) = match cut.cut_stat.st_label with + Anonymous -> + pf_get_new_id (id_of_string "_eq") gls0,false + | Name id -> id,true in + let thus_tac new_eq gls= + if _thus then + thus_tac (mkVar c_id) new_eq [] gls + else tclIDTAC gls in + match rew_side with + Lhs -> + let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in + tclTHENS (assert_postpone c_id new_eq) + [tclTHEN tcl_erase_info + (tclTHENS (transitivity lhs) + [just_tac;exact_check (mkVar last_id)]); + thus_tac new_eq] gls0 + | Rhs -> + let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in + tclTHENS (assert_postpone c_id new_eq) + [tclTHEN tcl_erase_info + (tclTHENS (transitivity rhs) + [exact_check (mkVar last_id);just_tac]); + thus_tac new_eq] gls0 + + + +(* tactics for claim/focus *) + +let instr_claim _thus st gls0 = + let info = get_its_info gls0 in + let (id,_) = match st.st_label with + Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false + | Name id -> id,true in + let thus_tac gls= + if _thus then + thus_tac (mkVar id) st.st_it [] gls + else tclIDTAC gls in + let ninfo1 = {pm_stack= + (if _thus then Focus_claim else Claim)::info.pm_stack} in + tclTHENS (assert_postpone id st.st_it) + [tcl_change_info ninfo1; + thus_tac] gls0 + +(* tactics for assume *) + +let push_intro_tac coerce nam gls = + let (hid,_) = + match nam with + Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false + | Name id -> id,true in + tclTHENLIST + [intro_mustbe_force hid; + coerce hid] + gls + +let assume_tac hyps gls = + List.fold_right + (fun (Hvar st | Hprop st) -> + tclTHEN + (push_intro_tac + (fun id -> + convert_hyp (id,None,st.st_it)) st.st_label)) + hyps tclIDTAC gls + +let assume_hyps_or_theses hyps gls = + List.fold_right + (function + (Hvar {st_label=nam;st_it=c} | Hprop {st_label=nam;st_it=This c}) -> + tclTHEN + (push_intro_tac + (fun id -> + convert_hyp (id,None,c)) nam) + | Hprop {st_label=nam;st_it=Thesis (tk)} -> + tclTHEN + (push_intro_tac + (fun id -> tclIDTAC) nam)) + hyps tclIDTAC gls + +let assume_st hyps gls = + List.fold_right + (fun st -> + tclTHEN + (push_intro_tac + (fun id -> convert_hyp (id,None,st.st_it)) st.st_label)) + hyps tclIDTAC gls + +let assume_st_letin hyps gls = + List.fold_right + (fun st -> + tclTHEN + (push_intro_tac + (fun id -> + convert_hyp (id,Some (fst st.st_it),snd st.st_it)) st.st_label)) + hyps tclIDTAC gls + +(* suffices *) + +let rec metas_from n hyps = + match hyps with + _ :: q -> n :: metas_from (succ n) q + | [] -> [] + +let rec build_product args body = + match args with + (Hprop st| Hvar st )::rest -> + let pprod= lift 1 (build_product rest body) in + let lbody = + match st.st_label with + Anonymous -> pprod + | Name id -> subst_term (mkVar id) pprod in + mkProd (st.st_label, st.st_it, lbody) + | [] -> body + +let rec build_applist prod = function + [] -> [],prod + | n::q -> + let (_,typ,_) = destProd prod in + let ctx,head = build_applist (Term.prod_applist prod [mkMeta n]) q in + (n,typ)::ctx,head + +let instr_suffices _then cut gls0 = + let info = get_its_info gls0 in + let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in + let ctx,hd = cut.cut_stat in + let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in + let metas = metas_from 1 ctx in + let c_ctx,c_head = build_applist c_stat metas in + let c_term = applist (mkVar c_id,List.map mkMeta metas) in + let thus_tac gls= + thus_tac c_term c_head c_ctx gls in + tclTHENS (assert_postpone c_id c_stat) + [tclTHENLIST + [ assume_tac ctx; + tcl_erase_info; + just_tac _then cut info]; + thus_tac] gls0 + +(* tactics for consider/given *) + +let conjunction_arity id gls = + let typ = pf_get_hyp_typ gls id in + let hd,params = decompose_app (special_whd gls typ) in + let env =pf_env gls in + match kind_of_term hd with + Ind ind when is_good_inductive env ind -> + let mib,oib= + Inductive.lookup_mind_specif env ind in + let gentypes= + Inductive.arities_of_constructors ind (mib,oib) in + let _ = if Array.length gentypes <> 1 then raise Not_found in + let apptype = Term.prod_applist gentypes.(0) params in + let rc,_ = Reduction.dest_prod env apptype in + List.length rc + | _ -> raise Not_found + +let rec intron_then n ids ltac gls = + if n<=0 then + ltac ids gls + else + let id = pf_get_new_id (id_of_string "_tmp") gls in + tclTHEN + (intro_mustbe_force id) + (intron_then (pred n) (id::ids) ltac) gls + + +let rec consider_match may_intro introduced available expected gls = + match available,expected with + [],[] -> + tclIDTAC gls + | _,[] -> error "Last statements do not match a complete hypothesis." + (* should tell which ones *) + | [],hyps -> + if may_intro then + begin + let id = pf_get_new_id (id_of_string "_tmp") gls in + tclIFTHENELSE + (intro_mustbe_force id) + (consider_match true [] [id] hyps) + (fun _ -> + error "Not enough sub-hypotheses to match statements.") + gls + end + else + error "Not enough sub-hypotheses to match statements." + (* should tell which ones *) + | id::rest_ids,(Hvar st | Hprop st)::rest -> + tclIFTHENELSE (convert_hyp (id,None,st.st_it)) + begin + match st.st_label with + Anonymous -> + consider_match may_intro ((id,false)::introduced) rest_ids rest + | Name hid -> + tclTHENLIST + [rename_hyp [id,hid]; + consider_match may_intro ((hid,true)::introduced) rest_ids rest] + end + begin + (fun gls -> + let nhyps = + try conjunction_arity id gls with + Not_found -> error "Matching hypothesis not found." in + tclTHENLIST + [general_case_analysis false (mkVar id,NoBindings); + intron_then nhyps [] + (fun l -> consider_match may_intro introduced + (List.rev_append l rest_ids) expected)] gls) + end + gls + +let consider_tac c hyps gls = + match kind_of_term (strip_outer_cast c) with + Var id -> + consider_match false [] [id] hyps gls + | _ -> + let id = pf_get_new_id (id_of_string "_tmp") gls in + tclTHEN + (forward None (Some (dummy_loc, Genarg.IntroIdentifier id)) c) + (consider_match false [] [id] hyps) gls + + +let given_tac hyps gls = + consider_match true [] [] hyps gls + +(* tactics for take *) + +let rec take_tac wits gls = + match wits with + [] -> tclIDTAC gls + | wit::rest -> + let typ = pf_type_of gls wit in + tclTHEN (thus_tac wit typ []) (take_tac rest) gls + + +(* tactics for define *) + +let rec build_function args body = + match args with + st::rest -> + let pfun= lift 1 (build_function rest body) in + let id = match st.st_label with + Anonymous -> assert false + | Name id -> id in + mkLambda (Name id, st.st_it, subst_term (mkVar id) pfun) + | [] -> body + +let define_tac id args body gls = + let t = build_function args body in + letin_tac None (Name id) t None Tacexpr.nowhere gls + +(* tactics for reconsider *) + +let cast_tac id_or_thesis typ gls = + match id_or_thesis with + This id -> + let (_,body,_) = pf_get_hyp gls id in + convert_hyp (id,body,typ) gls + | Thesis (For _ ) -> + error "\"thesis for ...\" is not applicable here." + | Thesis Plain -> + convert_concl typ DEFAULTcast gls + +(* per cases *) + +let is_rec_pos (main_ind,wft) = + match main_ind with + None -> false + | Some index -> + match fst (Rtree.dest_node wft) with + Mrec i when i = index -> true + | _ -> false + +let rec constr_trees (main_ind,wft) ind = + match Rtree.dest_node wft with + Norec,_ -> + let itree = + (snd (Global.lookup_inductive ind)).mind_recargs in + constr_trees (None,itree) ind + | _,constrs -> main_ind,constrs + +let ind_args rp ind = + let main_ind,constrs = constr_trees rp ind in + let args ctree = + Array.map (fun t -> main_ind,t) (snd (Rtree.dest_node ctree)) in + Array.map args constrs + +let init_tree ids ind rp nexti = + let indargs = ind_args rp ind in + let do_i i arp = (Array.map is_rec_pos arp),nexti i arp in + Split_patt (ids,ind,Array.mapi do_i indargs) + +let map_tree_rp rp id_fun mapi = function + Split_patt (ids,ind,branches) -> + let indargs = ind_args rp ind in + let do_i i (recargs,bri) = recargs,mapi i indargs.(i) bri in + Split_patt (id_fun ids,ind,Array.mapi do_i branches) + | _ -> failwith "map_tree_rp: not a splitting node" + +let map_tree id_fun mapi = function + Split_patt (ids,ind,branches) -> + let do_i i (recargs,bri) = recargs,mapi i bri in + Split_patt (id_fun ids,ind,Array.mapi do_i branches) + | _ -> failwith "map_tree: not a splitting node" + + +let start_tree env ind rp = + init_tree Idset.empty ind rp (fun _ _ -> None) + +let build_per_info etype casee gls = + let concl=pf_concl gls in + let env=pf_env gls in + let ctyp=pf_type_of gls casee in + let is_dep = dependent casee concl in + let hd,args = decompose_app (special_whd gls ctyp) in + let ind = + try + destInd hd + with _ -> + error "Case analysis must be done on an inductive object." in + let mind,oind = Global.lookup_inductive ind in + let nparams,index = + match etype with + ET_Induction -> mind.mind_nparams_rec,Some (snd ind) + | _ -> mind.mind_nparams,None in + let params,real_args = list_chop nparams args in + let abstract_obj c body = + let typ=pf_type_of gls c in + lambda_create env (typ,subst_term c body) in + let pred= List.fold_right abstract_obj + real_args (lambda_create env (ctyp,subst_term casee concl)) in + is_dep, + {per_casee=casee; + per_ctype=ctyp; + per_ind=ind; + per_pred=pred; + per_args=real_args; + per_params=params; + per_nparams=nparams; + per_wf=index,oind.mind_recargs} + +let per_tac etype casee gls= + let env=pf_env gls in + let info = get_its_info gls in + match casee with + Real c -> + let is_dep,per_info = build_per_info etype c gls in + let ek = + if is_dep then + EK_dep (start_tree env per_info.per_ind per_info.per_wf) + else EK_unknown in + tcl_change_info + {pm_stack= + Per(etype,per_info,ek,[])::info.pm_stack} gls + | Virtual cut -> + assert (cut.cut_stat.st_label=Anonymous); + let id = pf_get_new_id (id_of_string "anonymous_matched") gls in + let c = mkVar id in + let modified_cut = + {cut with cut_stat={cut.cut_stat with st_label=Name id}} in + tclTHEN + (instr_cut (fun _ _ c -> c) false false modified_cut) + (fun gls0 -> + let is_dep,per_info = build_per_info etype c gls0 in + assert (not is_dep); + tcl_change_info + {pm_stack= + Per(etype,per_info,EK_unknown,[])::info.pm_stack} gls0) + gls + +(* suppose *) + +let register_nodep_subcase id= function + Per(et,pi,ek,clauses)::s -> + begin + match ek with + EK_unknown -> clauses,Per(et,pi,EK_nodep,id::clauses)::s + | EK_nodep -> clauses,Per(et,pi,EK_nodep,id::clauses)::s + | EK_dep _ -> error "Do not mix \"suppose\" with \"suppose it is\"." + end + | _ -> anomaly "wrong stack state" + +let suppose_tac hyps gls0 = + let info = get_its_info gls0 in + let thesis = pf_concl gls0 in + let id = pf_get_new_id (id_of_string "subcase_") gls0 in + let clause = build_product hyps thesis in + let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in + let old_clauses,stack = register_nodep_subcase id info.pm_stack in + let ninfo2 = {pm_stack=stack} in + tclTHENS (assert_postpone id clause) + [tclTHENLIST [tcl_change_info ninfo1; + assume_tac hyps; + clear old_clauses]; + tcl_change_info ninfo2] gls0 + +(* suppose it is ... *) + +(* pattern matching compiling *) + +let rec skip_args rest ids n = + if n <= 0 then + Close_patt rest + else + Skip_patt (ids,skip_args rest ids (pred n)) + +let rec tree_of_pats ((id,_) as cpl) pats = + match pats with + [] -> End_patt cpl + | args::stack -> + match args with + [] -> Close_patt (tree_of_pats cpl stack) + | (patt,rp) :: rest_args -> + match patt with + PatVar (_,v) -> + Skip_patt (Idset.singleton id, + tree_of_pats cpl (rest_args::stack)) + | PatCstr (_,(ind,cnum),args,nam) -> + let nexti i ati = + if i = pred cnum then + let nargs = + list_map_i (fun j a -> (a,ati.(j))) 0 args in + Some (Idset.singleton id, + tree_of_pats cpl (nargs::rest_args::stack)) + else None + in init_tree Idset.empty ind rp nexti + +let rec add_branch ((id,_) as cpl) pats tree= + match pats with + [] -> + begin + match tree with + End_patt cpl0 -> End_patt cpl0 + (* this ensures precedence for overlapping patterns *) + | _ -> anomaly "tree is expected to end here" + end + | args::stack -> + match args with + [] -> + begin + match tree with + Close_patt t -> + Close_patt (add_branch cpl stack t) + | _ -> anomaly "we should pop here" + end + | (patt,rp) :: rest_args -> + match patt with + PatVar (_,v) -> + begin + match tree with + Skip_patt (ids,t) -> + Skip_patt (Idset.add id ids, + add_branch cpl (rest_args::stack) t) + | Split_patt (_,_,_) -> + map_tree (Idset.add id) + (fun i bri -> + append_branch cpl 1 (rest_args::stack) bri) + tree + | _ -> anomaly "No pop/stop expected here" + end + | PatCstr (_,(ind,cnum),args,nam) -> + match tree with + Skip_patt (ids,t) -> + let nexti i ati = + if i = pred cnum then + let nargs = + list_map_i (fun j a -> (a,ati.(j))) 0 args in + Some (Idset.add id ids, + add_branch cpl (nargs::rest_args::stack) + (skip_args t ids (Array.length ati))) + else + Some (ids, + skip_args t ids (Array.length ati)) + in init_tree ids ind rp nexti + | Split_patt (_,ind0,_) -> + if (ind <> ind0) then error + (* this can happen with coercions *) + "Case pattern belongs to wrong inductive type."; + let mapi i ati bri = + if i = pred cnum then + let nargs = + list_map_i (fun j a -> (a,ati.(j))) 0 args in + append_branch cpl 0 + (nargs::rest_args::stack) bri + else bri in + map_tree_rp rp (fun ids -> ids) mapi tree + | _ -> anomaly "No pop/stop expected here" +and append_branch ((id,_) as cpl) depth pats = function + Some (ids,tree) -> + Some (Idset.add id ids,append_tree cpl depth pats tree) + | None -> + Some (Idset.singleton id,tree_of_pats cpl pats) +and append_tree ((id,_) as cpl) depth pats tree = + if depth<=0 then add_branch cpl pats tree + else match tree with + Close_patt t -> + Close_patt (append_tree cpl (pred depth) pats t) + | Skip_patt (ids,t) -> + Skip_patt (Idset.add id ids,append_tree cpl depth pats t) + | End_patt _ -> anomaly "Premature end of branch" + | Split_patt (_,_,_) -> + map_tree (Idset.add id) + (fun i bri -> append_branch cpl (succ depth) pats bri) tree + +(* suppose it is *) + +let rec st_assoc id = function + [] -> raise Not_found + | st::_ when st.st_label = id -> st.st_it + | _ :: rest -> st_assoc id rest + +let thesis_for obj typ per_info env= + let rc,hd1=decompose_prod typ in + let cind,all_args=decompose_app typ in + let ind = destInd cind in + let _ = if ind <> per_info.per_ind then + errorlabstrm "thesis_for" + ((Printer.pr_constr_env env obj) ++ spc () ++ + str"cannot give an induction hypothesis (wrong inductive type).") in + let params,args = list_chop per_info.per_nparams all_args in + let _ = if not (List.for_all2 eq_constr params per_info.per_params) then + errorlabstrm "thesis_for" + ((Printer.pr_constr_env env obj) ++ spc () ++ + str "cannot give an induction hypothesis (wrong parameters).") in + let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in + compose_prod rc (whd_beta Evd.empty hd2) + +let rec build_product_dep pat_info per_info args body gls = + match args with + (Hprop {st_label=nam;st_it=This c} + | Hvar {st_label=nam;st_it=c})::rest -> + let pprod= + lift 1 (build_product_dep pat_info per_info rest body gls) in + let lbody = + match nam with + Anonymous -> body + | Name id -> subst_var id pprod in + mkProd (nam,c,lbody) + | Hprop ({st_it=Thesis tk} as st)::rest -> + let pprod= + lift 1 (build_product_dep pat_info per_info rest body gls) in + let lbody = + match st.st_label with + Anonymous -> body + | Name id -> subst_var id pprod in + let ptyp = + match tk with + For id -> + let obj = mkVar id in + let typ = + try st_assoc (Name id) pat_info.pat_vars + with Not_found -> + snd (st_assoc (Name id) pat_info.pat_aliases) in + thesis_for obj typ per_info (pf_env gls) + | Plain -> pf_concl gls in + mkProd (st.st_label,ptyp,lbody) + | [] -> body + +let build_dep_clause params pat_info per_info hyps gls = + let concl= + thesis_for pat_info.pat_constr pat_info.pat_typ per_info (pf_env gls) in + let open_clause = + build_product_dep pat_info per_info hyps concl gls in + let prod_one st body = + match st.st_label with + Anonymous -> mkProd(Anonymous,st.st_it,lift 1 body) + | Name id -> mkNamedProd id st.st_it (lift 1 body) in + let let_one_in st body = + match st.st_label with + Anonymous -> mkLetIn(Anonymous,fst st.st_it,snd st.st_it,lift 1 body) + | Name id -> + mkNamedLetIn id (fst st.st_it) (snd st.st_it) (lift 1 body) in + let aliased_clause = + List.fold_right let_one_in pat_info.pat_aliases open_clause in + List.fold_right prod_one (params@pat_info.pat_vars) aliased_clause + +let rec register_dep_subcase id env per_info pat = function + EK_nodep -> error "Only \"suppose it is\" can be used here." + | EK_unknown -> + register_dep_subcase id env per_info pat + (EK_dep (start_tree env per_info.per_ind per_info.per_wf)) + | EK_dep tree -> EK_dep (add_branch id [[pat,per_info.per_wf]] tree) + +let case_tac params pat_info hyps gls0 = + let info = get_its_info gls0 in + let id = pf_get_new_id (id_of_string "subcase_") gls0 in + let et,per_info,ek,old_clauses,rest = + match info.pm_stack with + Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest) + | _ -> anomaly "wrong place for cases" in + let clause = build_dep_clause params pat_info per_info hyps gls0 in + let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in + let nek = + register_dep_subcase (id,(List.length params,List.length hyps)) + (pf_env gls0) per_info pat_info.pat_pat ek in + let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in + tclTHENS (assert_postpone id clause) + [tclTHENLIST + [tcl_change_info ninfo1; + assume_st (params@pat_info.pat_vars); + assume_st_letin pat_info.pat_aliases; + assume_hyps_or_theses hyps; + clear old_clauses]; + tcl_change_info ninfo2] gls0 + +(* end cases *) + +type instance_stack = + (constr option*(constr list) list) list + +let initial_instance_stack ids = + List.map (fun id -> id,[None,[]]) ids + +let push_one_arg arg = function + [] -> anomaly "impossible" + | (head,args) :: ctx -> + ((head,(arg::args)) :: ctx) + +let push_arg arg stacks = + List.map (fun (id,stack) -> (id,push_one_arg arg stack)) stacks + + +let push_one_head c ids (id,stack) = + let head = if Idset.mem id ids then Some c else None in + id,(head,[]) :: stack + +let push_head c ids stacks = + List.map (push_one_head c ids) stacks + +let pop_one (id,stack) = + let nstack= + match stack with + [] -> anomaly "impossible" + | [c] as l -> l + | (Some head,args)::(head0,args0)::ctx -> + let arg = applist (head,(List.rev args)) in + (head0,(arg::args0))::ctx + | (None,args)::(head0,args0)::ctx -> + (head0,(args@args0))::ctx + in id,nstack + +let pop_stacks stacks = + List.map pop_one stacks + +let hrec_for fix_id per_info gls obj_id = + let obj=mkVar obj_id in + let typ=pf_get_hyp_typ gls obj_id in + let rc,hd1=decompose_prod typ in + let cind,all_args=decompose_app typ in + let ind = destInd cind in assert (ind=per_info.per_ind); + let params,args= list_chop per_info.per_nparams all_args in + assert begin + try List.for_all2 eq_constr params per_info.per_params with + Invalid_argument _ -> false end; + let hd2 = applist (mkVar fix_id,args@[obj]) in + compose_lam rc (whd_beta gls.sigma hd2) + + +let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = + match tree, objs with + Close_patt t,_ -> + let args0 = pop_stacks args in + execute_cases fix_name per_info tacnext args0 objs nhrec t gls + | Skip_patt (_,t),skipped::next_objs -> + let args0 = push_arg skipped args in + execute_cases fix_name per_info tacnext args0 next_objs nhrec t gls + | End_patt (id,(nparams,nhyps)),[] -> + begin + match List.assoc id args with + [None,br_args] -> + let all_metas = + list_tabulate (fun n -> mkMeta (succ n)) (nparams + nhyps) in + let param_metas,hyp_metas = list_chop nparams all_metas in + tclTHEN + (tclDO nhrec introf) + (tacnext + (applist (mkVar id, + List.append param_metas + (List.rev_append br_args hyp_metas)))) gls + | _ -> anomaly "wrong stack size" + end + | Split_patt (ids,ind,br), casee::next_objs -> + let (mind,oind) as spec = Global.lookup_inductive ind in + let nparams = mind.mind_nparams in + let concl=pf_concl gls in + let env=pf_env gls in + let ctyp=pf_type_of gls casee in + let hd,all_args = decompose_app (special_whd gls ctyp) in + let _ = assert (destInd hd = ind) in (* just in case *) + let params,real_args = list_chop nparams all_args in + let abstract_obj c body = + let typ=pf_type_of gls c in + lambda_create env (typ,subst_term c body) in + let elim_pred = List.fold_right abstract_obj + real_args (lambda_create env (ctyp,subst_term casee concl)) in + let case_info = Inductiveops.make_case_info env ind RegularStyle in + let gen_arities = Inductive.arities_of_constructors ind spec in + let f_ids typ = + let sign = + (prod_assum (Term.prod_applist typ params)) in + find_intro_names sign gls in + let constr_args_ids = Array.map f_ids gen_arities in + let case_term = + mkCase(case_info,elim_pred,casee, + Array.mapi (fun i _ -> mkMeta (succ i)) constr_args_ids) in + let branch_tac i (recargs,bro) gls0 = + let args_ids = constr_args_ids.(i) in + let rec aux n = function + [] -> + assert (n=Array.length recargs); + next_objs,[],nhrec + | id :: q -> + let objs,recs,nrec = aux (succ n) q in + if recargs.(n) + then (mkVar id::objs),(id::recs),succ nrec + else (mkVar id::objs),recs,nrec in + let objs,recs,nhrec = aux 0 args_ids in + tclTHENLIST + [tclMAP intro_mustbe_force args_ids; + begin + fun gls1 -> + let hrecs = + List.map + (fun id -> + hrec_for (out_name fix_name) per_info gls1 id) + recs in + generalize hrecs gls1 + end; + match bro with + None -> + msg_warning (str "missing case"); + tacnext (mkMeta 1) + | Some (sub_ids,tree) -> + let br_args = + List.filter + (fun (id,_) -> Idset.mem id sub_ids) args in + let construct = + applist (mkConstruct(ind,succ i),params) in + let p_args = + push_head construct ids br_args in + execute_cases fix_name per_info tacnext + p_args objs nhrec tree] gls0 in + tclTHENSV + (refine case_term) + (Array.mapi branch_tac br) gls + | Split_patt (_, _, _) , [] -> + anomaly "execute_cases : Nothing to split" + | Skip_patt _ , [] -> + anomaly "execute_cases : Nothing to skip" + | End_patt (_,_) , _ :: _ -> + anomaly "execute_cases : End of branch with garbage left" + +let understand_my_constr c gls = + let env = pf_env gls in + let nc = names_of_rel_context env in + let rawc = Detyping.detype false [] nc c in + let rec frob = function REvar _ -> RHole (dummy_loc,QuestionMark Expand) | rc -> map_rawconstr frob rc in + Pretyping.Default.understand_tcc (sig_sig gls) env ~expected_type:(pf_concl gls) (frob rawc) + +let set_refine,my_refine = +let refine = ref (fun (_:open_constr) -> (assert false : tactic) ) in +((fun tac -> refine:= tac), +(fun c gls -> + let oc = understand_my_constr c gls in + !refine oc gls)) + +(* end focus/claim *) + +let end_tac et2 gls = + let info = get_its_info gls in + let et1,pi,ek,clauses = + match info.pm_stack with + Suppose_case::_ -> + anomaly "This case should already be trapped" + | Claim::_ -> + error "\"end claim\" expected." + | Focus_claim::_ -> + error "\"end focus\" expected." + | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses) + | [] -> + anomaly "This case should already be trapped" in + let et = + if et1 <> et2 then + match et1 with + ET_Case_analysis -> + error "\"end cases\" expected." + | ET_Induction -> + error "\"end induction\" expected." + else et1 in + tclTHEN + tcl_erase_info + begin + match et,ek with + _,EK_unknown -> + tclSOLVE [simplest_elim pi.per_casee] + | ET_Case_analysis,EK_nodep -> + tclTHEN + (general_case_analysis false (pi.per_casee,NoBindings)) + (default_justification (List.map mkVar clauses)) + | ET_Induction,EK_nodep -> + tclTHENLIST + [generalize (pi.per_args@[pi.per_casee]); + simple_induct (AnonHyp (succ (List.length pi.per_args))); + default_justification (List.map mkVar clauses)] + | ET_Case_analysis,EK_dep tree -> + execute_cases Anonymous pi + (fun c -> tclTHENLIST + [my_refine c; + clear clauses; + justification assumption]) + (initial_instance_stack clauses) [pi.per_casee] 0 tree + | ET_Induction,EK_dep tree -> + let nargs = (List.length pi.per_args) in + tclTHEN (generalize (pi.per_args@[pi.per_casee])) + begin + fun gls0 -> + let fix_id = + pf_get_new_id (id_of_string "_fix") gls0 in + let c_id = + pf_get_new_id (id_of_string "_main_arg") gls0 in + tclTHENLIST + [fix (Some fix_id) (succ nargs); + tclDO nargs introf; + intro_mustbe_force c_id; + execute_cases (Name fix_id) pi + (fun c -> + tclTHENLIST + [clear [fix_id]; + my_refine c; + clear clauses; + justification assumption]) + (initial_instance_stack clauses) + [mkVar c_id] 0 tree] gls0 + end + end gls + +(* escape *) + +let escape_tac gls = tcl_erase_info gls + +(* General instruction engine *) + +let rec do_proof_instr_gen _thus _then instr = + match instr with + Pthus i -> + assert (not _thus); + do_proof_instr_gen true _then i + | Pthen i -> + assert (not _then); + do_proof_instr_gen _thus true i + | Phence i -> + assert (not (_then || _thus)); + do_proof_instr_gen true true i + | Pcut c -> + instr_cut mk_stat_or_thesis _thus _then c + | Psuffices c -> + instr_suffices _then c + | Prew (s,c) -> + assert (not _then); + instr_rew _thus s c + | Pconsider (c,hyps) -> consider_tac c hyps + | Pgiven hyps -> given_tac hyps + | Passume hyps -> assume_tac hyps + | Plet hyps -> assume_tac hyps + | Pclaim st -> instr_claim false st + | Pfocus st -> instr_claim true st + | Ptake witl -> take_tac witl + | Pdefine (id,args,body) -> define_tac id args body + | Pcast (id,typ) -> cast_tac id typ + | Pper (et,cs) -> per_tac et cs + | Psuppose hyps -> suppose_tac hyps + | Pcase (params,pat_info,hyps) -> case_tac params pat_info hyps + | Pend (B_elim et) -> end_tac et + | Pend _ -> anomaly "Not applicable" + | Pescape -> escape_tac + +let eval_instr {instr=instr} = + do_proof_instr_gen false false instr + +let rec preprocess pts instr = + match instr with + Phence i |Pthus i | Pthen i -> preprocess pts i + | Psuffices _ | Pcut _ | Passume _ | Plet _ | Pclaim _ | Pfocus _ + | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ + | Pdefine (_,_,_) | Pper _ | Prew _ -> + check_not_per pts; + true + | Pescape -> + check_not_per pts; + true + | Pcase _ | Psuppose _ | Pend (B_elim _) -> + close_previous_case pts ; + true + | Pend bt -> + close_block bt pts ; + false + +let rec postprocess pts instr = + match instr with + Phence i | Pthus i | Pthen i -> postprocess pts i + | Pcut _ | Psuffices _ | Passume _ | Plet _ | Pconsider (_,_) | Pcast (_,_) + | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Prew (_,_) -> () + | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ + | Pescape -> Proof.focus proof_cond 1 pts + | Pend (B_elim ET_Induction) -> + begin + let pfterm = List.hd (Proof.partial_proof pts) in + let { it = gls ; sigma = sigma } = Proof.V82.subgoals pts in + let env = Goal.V82.env sigma (List.hd gls) in + try + Inductiveops.control_only_guard env pfterm; + goto_current_focus_or_top pts + with + Type_errors.TypeError(env, + Type_errors.IllFormedRecBody(_,_,_,_,_)) -> + anomaly "\"end induction\" generated an ill-formed fixpoint" + end + | Pend _ -> + goto_current_focus_or_top (pts) + +let do_instr raw_instr pts = + let has_tactic = preprocess pts raw_instr.instr in + begin + if has_tactic then + let { it=gls ; sigma=sigma } = Proof.V82.subgoals pts in + let gl = { it=List.hd gls ; sigma=sigma } in + let env= pf_env gl in + let ist = {ltacvars = ([],[]); ltacrecvars = []; + gsigma = sigma; genv = env} in + let glob_instr = intern_proof_instr ist raw_instr in + let instr = + interp_proof_instr (get_its_info gl) sigma env glob_instr in + Pfedit.by (tclTHEN (eval_instr instr) clean_tmp) + else () end; + postprocess pts raw_instr.instr + +let proof_instr raw_instr = + let p = Proof_global.give_me_the_proof () in + do_instr raw_instr p + +(* + +(* STUFF FOR ITERATED RELATIONS *) +let decompose_bin_app t= + let hd,args = destApp + +let identify_transitivity_lemma c = + let varx,tx,c1 = destProd c in + let vary,ty,c2 = destProd (pop c1) in + let varz,tz,c3 = destProd (pop c2) in + let _,p1,c4 = destProd (pop c3) in + let _,lp2,lp3 = destProd (pop c4) in + let p2=pop lp2 in + let p3=pop lp3 in +*) + diff --git a/plugins/decl_mode/decl_proof_instr.mli b/plugins/decl_mode/decl_proof_instr.mli new file mode 100644 index 0000000000..0b22b7ac53 --- /dev/null +++ b/plugins/decl_mode/decl_proof_instr.mli @@ -0,0 +1,115 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit +val return_from_tactic_mode: unit -> unit + +val register_automation_tac: tactic -> unit + +val automation_tac : tactic + +val daimon_subtree: Proof.proof -> Proof.proof + +val concl_refiner: + Termops.meta_type_map -> constr -> Proof_type.goal sigma -> constr + +val do_instr: Decl_expr.raw_proof_instr -> Proof.proof -> unit +val proof_instr: Decl_expr.raw_proof_instr -> unit + +val tcl_change_info : Decl_mode.pm_info -> tactic + +val execute_cases : + Names.name -> + Decl_mode.per_info -> + (Term.constr -> Proof_type.tactic) -> + (Names.Idset.elt * (Term.constr option * Term.constr list) list) list -> + Term.constr list -> int -> Decl_mode.split_tree -> Proof_type.tactic + +val tree_of_pats : + identifier * (int * int) -> (Rawterm.cases_pattern*recpath) list list -> + split_tree + +val add_branch : + identifier * (int * int) -> (Rawterm.cases_pattern*recpath) list list -> + split_tree -> split_tree + +val append_branch : + identifier *(int * int) -> int -> (Rawterm.cases_pattern*recpath) list list -> + (Names.Idset.t * Decl_mode.split_tree) option -> + (Names.Idset.t * Decl_mode.split_tree) option + +val append_tree : + identifier * (int * int) -> int -> (Rawterm.cases_pattern*recpath) list list -> + split_tree -> split_tree + +val build_dep_clause : Term.types Decl_expr.statement list -> + Decl_expr.proof_pattern -> + Decl_mode.per_info -> + (Term.types Decl_expr.statement, Term.types Decl_expr.or_thesis) + Decl_expr.hyp list -> Proof_type.goal Tacmach.sigma -> Term.types + +val register_dep_subcase : + Names.identifier * (int * int) -> + Environ.env -> + Decl_mode.per_info -> + Rawterm.cases_pattern -> Decl_mode.elim_kind -> Decl_mode.elim_kind + +val thesis_for : Term.constr -> + Term.constr -> Decl_mode.per_info -> Environ.env -> Term.constr + +val close_previous_case : Proof.proof -> unit + +val pop_stacks : + (Names.identifier * + (Term.constr option * Term.constr list) list) list -> + (Names.identifier * + (Term.constr option * Term.constr list) list) list + +val push_head : Term.constr -> + Names.Idset.t -> + (Names.identifier * + (Term.constr option * Term.constr list) list) list -> + (Names.identifier * + (Term.constr option * Term.constr list) list) list + +val push_arg : Term.constr -> + (Names.identifier * + (Term.constr option * Term.constr list) list) list -> + (Names.identifier * + (Term.constr option * Term.constr list) list) list + +val hrec_for: + Names.identifier -> + Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> + Names.identifier -> Term.constr + +val consider_match : + bool -> + (Names.Idset.elt*bool) list -> + Names.Idset.elt list -> + (Term.types Decl_expr.statement, Term.types) Decl_expr.hyp list -> + Proof_type.tactic + +val init_tree: + Names.Idset.t -> + Names.inductive -> + int option * Declarations.wf_paths -> + (int -> + (int option * Declarations.recarg Rtree.t) array -> + (Names.Idset.t * Decl_mode.split_tree) option) -> + Decl_mode.split_tree + +val set_refine : (Evd.open_constr -> Proof_type.tactic) -> unit diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 new file mode 100644 index 0000000000..cdfc57b374 --- /dev/null +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -0,0 +1,407 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (* declares the globalisation function *) + Genarg.in_gen globwit_proof_instr + (Decl_interp.intern_proof_instr e (Genarg.out_gen rawwit_proof_instr x)) + end, + begin fun ist gl x -> (* declares the interpretation function *) + Genarg.in_gen wit_proof_instr + (interp_proof_instr ist gl (Genarg.out_gen globwit_proof_instr x)) + end, + begin fun _ x -> x end (* declares the substitution function, irrelevant in our case *) + end + +let _ = Pptactic.declare_extra_genarg_pprule + (rawwit_proof_instr, pr_raw_proof_instr) + (globwit_proof_instr, pr_glob_proof_instr) + (wit_proof_instr, pr_proof_instr) + +(* We use the VERNAC EXTEND facility with a custom non-terminal + to populate [proof_mode] with a new toplevel interpreter. + The "-" indicates that the rule does not start with a distinguished + string. *) +VERNAC proof_mode EXTEND ProofInstr + [ - proof_instr(instr) ] -> [ vernac_proof_instr instr ] +END + +(* It is useful to use GEXTEND directly to call grammar entries that have been + defined previously VERNAC EXTEND. In this case we allow, in proof mode, + the use of commands like Check or Print. VERNAC EXTEND does quite a bit of + bureaucracy for us, but it is not needed in this sort of case, and it would require + to have an ARGUMENT EXTEND version of the "proof_mode" grammar entry. *) +GEXTEND Gram + GLOBAL: proof_mode ; + + proof_mode: LAST + [ [ c=G_vernac.subgoal_command -> c (Some 1) None ] ] + ; +END + +(* We register a new proof mode here *) + +let _ = + Proof_global.register_proof_mode { Proof_global. + name = "Declarative" ; (* name for identifying and printing *) + (* function [set] goes from No Proof Mode to + Declarative Proof Mode performing side effects *) + set = begin fun () -> + (* We set the command non terminal to + [proof_mode] (which we just defined). *) + G_vernac.set_command_entry proof_mode ; + (* We substitute the goal printer, by the one we built + for the proof mode. *) + Printer.set_printer_pr { Printer.default_printer_pr with + Printer.pr_goal = pr_goal } + end ; + (* function [reset] goes back to No Proof Mode from + Declarative Proof Mode *) + reset = begin fun () -> + (* We restore the command non terminal to + [noedit_mode]. *) + G_vernac.set_command_entry G_vernac.noedit_mode ; + (* We restore the goal printer to default *) + Printer.set_printer_pr Printer.default_printer_pr + end + } + +(* Two new vernacular commands *) +VERNAC COMMAND EXTEND DeclProof + [ "proof" ] -> [ vernac_decl_proof () ] +END +VERNAC COMMAND EXTEND DeclReturn + [ "return" ] -> [ vernac_return () ] +END + +let none_is_empty = function + None -> [] + | Some l -> l + +GEXTEND Gram +GLOBAL: proof_instr; + thesis : + [[ "thesis" -> Plain + | "thesis"; "for"; i=ident -> (For i) + ]]; + statement : + [[ i=ident ; ":" ; c=constr -> {st_label=Name i;st_it=c} + | i=ident -> {st_label=Anonymous; + st_it=Topconstr.CRef (Libnames.Ident (loc, i))} + | c=constr -> {st_label=Anonymous;st_it=c} + ]]; + constr_or_thesis : + [[ t=thesis -> Thesis t ] | + [ c=constr -> This c + ]]; + statement_or_thesis : + [ + [ t=thesis -> {st_label=Anonymous;st_it=Thesis t} ] + | + [ i=ident ; ":" ; cot=constr_or_thesis -> {st_label=Name i;st_it=cot} + | i=ident -> {st_label=Anonymous; + st_it=This (Topconstr.CRef (Libnames.Ident (loc, i)))} + | c=constr -> {st_label=Anonymous;st_it=This c} + ] + ]; + justification_items : + [[ -> Some [] + | "by"; l=LIST1 constr SEP "," -> Some l + | "by"; "*" -> None ]] + ; + justification_method : + [[ -> None + | "using"; tac = tactic -> Some tac ]] + ; + simple_cut_or_thesis : + [[ ls = statement_or_thesis; + j = justification_items; + taco = justification_method + -> {cut_stat=ls;cut_by=j;cut_using=taco} ]] + ; + simple_cut : + [[ ls = statement; + j = justification_items; + taco = justification_method + -> {cut_stat=ls;cut_by=j;cut_using=taco} ]] + ; + elim_type: + [[ IDENT "induction" -> ET_Induction + | IDENT "cases" -> ET_Case_analysis ]] + ; + block_type : + [[ IDENT "claim" -> B_claim + | IDENT "focus" -> B_focus + | IDENT "proof" -> B_proof + | et=elim_type -> B_elim et ]] + ; + elim_obj: + [[ IDENT "on"; c=constr -> Real c + | IDENT "of"; c=simple_cut -> Virtual c ]] + ; + elim_step: + [[ IDENT "consider" ; + h=consider_vars ; IDENT "from" ; c=constr -> Pconsider (c,h) + | IDENT "per"; et=elim_type; obj=elim_obj -> Pper (et,obj) + | IDENT "suffices"; ls=suff_clause; + j = justification_items; + taco = justification_method + -> Psuffices {cut_stat=ls;cut_by=j;cut_using=taco} ]] + ; + rew_step : + [[ "~=" ; c=simple_cut -> (Rhs,c) + | "=~" ; c=simple_cut -> (Lhs,c)]] + ; + cut_step: + [[ "then"; tt=elim_step -> Pthen tt + | "then"; c=simple_cut_or_thesis -> Pthen (Pcut c) + | IDENT "thus"; tt=rew_step -> Pthus (let s,c=tt in Prew (s,c)) + | IDENT "thus"; c=simple_cut_or_thesis -> Pthus (Pcut c) + | IDENT "hence"; c=simple_cut_or_thesis -> Phence (Pcut c) + | tt=elim_step -> tt + | tt=rew_step -> let s,c=tt in Prew (s,c); + | IDENT "have"; c=simple_cut_or_thesis -> Pcut c; + | IDENT "claim"; c=statement -> Pclaim c; + | IDENT "focus"; IDENT "on"; c=statement -> Pfocus c; + | "end"; bt = block_type -> Pend bt; + | IDENT "escape" -> Pescape ]] + ; + (* examiner s'il est possible de faire R _ et _ R pour R une relation qcq*) + loc_id: + [[ id=ident -> fun x -> (loc,(id,x)) ]]; + hyp: + [[ id=loc_id -> id None ; + | id=loc_id ; ":" ; c=constr -> id (Some c)]] + ; + consider_vars: + [[ name=hyp -> [Hvar name] + | name=hyp; ","; v=consider_vars -> (Hvar name) :: v + | name=hyp; + IDENT "such"; IDENT "that"; h=consider_hyps -> (Hvar name)::h + ]] + ; + consider_hyps: + [[ st=statement; IDENT "and"; h=consider_hyps -> Hprop st::h + | st=statement; IDENT "and"; + IDENT "consider" ; v=consider_vars -> Hprop st::v + | st=statement -> [Hprop st] + ]] + ; + assume_vars: + [[ name=hyp -> [Hvar name] + | name=hyp; ","; v=assume_vars -> (Hvar name) :: v + | name=hyp; + IDENT "such"; IDENT "that"; h=assume_hyps -> (Hvar name)::h + ]] + ; + assume_hyps: + [[ st=statement; IDENT "and"; h=assume_hyps -> Hprop st::h + | st=statement; IDENT "and"; + IDENT "we"; IDENT "have" ; v=assume_vars -> Hprop st::v + | st=statement -> [Hprop st] + ]] + ; + assume_clause: + [[ IDENT "we" ; IDENT "have" ; v=assume_vars -> v + | h=assume_hyps -> h ]] + ; + suff_vars: + [[ name=hyp; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> + [Hvar name],c + | name=hyp; ","; v=suff_vars -> + let (q,c) = v in ((Hvar name) :: q),c + | name=hyp; + IDENT "such"; IDENT "that"; h=suff_hyps -> + let (q,c) = h in ((Hvar name) :: q),c + ]]; + suff_hyps: + [[ st=statement; IDENT "and"; h=suff_hyps -> + let (q,c) = h in (Hprop st::q),c + | st=statement; IDENT "and"; + IDENT "to" ; IDENT "have" ; v=suff_vars -> + let (q,c) = v in (Hprop st::q),c + | st=statement; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> + [Hprop st],c + ]] + ; + suff_clause: + [[ IDENT "to" ; IDENT "have" ; v=suff_vars -> v + | h=suff_hyps -> h ]] + ; + let_vars: + [[ name=hyp -> [Hvar name] + | name=hyp; ","; v=let_vars -> (Hvar name) :: v + | name=hyp; IDENT "be"; + IDENT "such"; IDENT "that"; h=let_hyps -> (Hvar name)::h + ]] + ; + let_hyps: + [[ st=statement; IDENT "and"; h=let_hyps -> Hprop st::h + | st=statement; IDENT "and"; "let"; v=let_vars -> Hprop st::v + | st=statement -> [Hprop st] + ]]; + given_vars: + [[ name=hyp -> [Hvar name] + | name=hyp; ","; v=given_vars -> (Hvar name) :: v + | name=hyp; IDENT "such"; IDENT "that"; h=given_hyps -> (Hvar name)::h + ]] + ; + given_hyps: + [[ st=statement; IDENT "and"; h=given_hyps -> Hprop st::h + | st=statement; IDENT "and"; IDENT "given"; v=given_vars -> Hprop st::v + | st=statement -> [Hprop st] + ]]; + suppose_vars: + [[name=hyp -> [Hvar name] + |name=hyp; ","; v=suppose_vars -> (Hvar name) :: v + |name=hyp; OPT[IDENT "be"]; + IDENT "such"; IDENT "that"; h=suppose_hyps -> (Hvar name)::h + ]] + ; + suppose_hyps: + [[ st=statement_or_thesis; IDENT "and"; h=suppose_hyps -> Hprop st::h + | st=statement_or_thesis; IDENT "and"; IDENT "we"; IDENT "have"; + v=suppose_vars -> Hprop st::v + | st=statement_or_thesis -> [Hprop st] + ]] + ; + suppose_clause: + [[ IDENT "we"; IDENT "have"; v=suppose_vars -> v; + | h=suppose_hyps -> h ]] + ; + intro_step: + [[ IDENT "suppose" ; h=assume_clause -> Psuppose h + | IDENT "suppose" ; IDENT "it"; IDENT "is" ; c=pattern LEVEL "0" ; + po=OPT[ "with"; p=LIST1 hyp SEP ","-> p ] ; + ho=OPT[ IDENT "and" ; h=suppose_clause -> h ] -> + Pcase (none_is_empty po,c,none_is_empty ho) + | "let" ; v=let_vars -> Plet v + | IDENT "take"; witnesses = LIST1 constr SEP "," -> Ptake witnesses + | IDENT "assume"; h=assume_clause -> Passume h + | IDENT "given"; h=given_vars -> Pgiven h + | IDENT "define"; id=ident; args=LIST0 hyp; + "as"; body=constr -> Pdefine(id,args,body) + | IDENT "reconsider"; id=ident; "as" ; typ=constr -> Pcast (This id,typ) + | IDENT "reconsider"; t=thesis; "as" ; typ=constr -> Pcast (Thesis t ,typ) + ]] + ; + emphasis : + [[ -> 0 + | "*" -> 1 + | "**" -> 2 + | "***" -> 3 + ]] + ; + bare_proof_instr: + [[ c = cut_step -> c ; + | i = intro_step -> i ]] + ; + proof_instr : + [[ e=emphasis;i=bare_proof_instr -> {emph=e;instr=i}]] + ; +END;; + + diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml new file mode 100644 index 0000000000..40c712cdff --- /dev/null +++ b/plugins/decl_mode/ppdecl_proof.ml @@ -0,0 +1,190 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* mt () + | Name id -> pr_id id ++ spc () ++ str ":" ++ spc () + +let pr_justification_items env = function + Some [] -> mt () + | Some (_::_ as l) -> + spc () ++ str "by" ++ spc () ++ + prlist_with_sep (fun () -> str ",") (pr_constr env) l + | None -> spc () ++ str "by *" + +let pr_justification_method env = function + None -> mt () + | Some tac -> + spc () ++ str "using" ++ spc () ++ pr_tac env tac + +let pr_statement pr_it env st = + pr_label st.st_label ++ pr_it env st.st_it + +let pr_or_thesis pr_this env = function + Thesis Plain -> str "thesis" + | Thesis (For id) -> + str "thesis" ++ spc() ++ str "for" ++ spc () ++ pr_id id + | This c -> pr_this env c + +let pr_cut pr_it env c = + hov 1 (pr_it env c.cut_stat) ++ + pr_justification_items env c.cut_by ++ + pr_justification_method env c.cut_using + +let type_or_thesis = function + Thesis _ -> Term.mkProp + | This c -> c + +let _I x = x + +let rec print_hyps pconstr gtyp env sep _be _have hyps = + let pr_sep = if sep then str "and" ++ spc () else mt () in + match hyps with + (Hvar _ ::_) as rest -> + spc () ++ pr_sep ++ str _have ++ + print_vars pconstr gtyp env false _be _have rest + | Hprop st :: rest -> + begin + let nenv = + match st.st_label with + Anonymous -> env + | Name id -> Environ.push_named (id,None,gtyp st.st_it) env in + spc() ++ pr_sep ++ pr_statement pconstr env st ++ + print_hyps pconstr gtyp nenv true _be _have rest + end + | [] -> mt () + +and print_vars pconstr gtyp env sep _be _have vars = + match vars with + Hvar st :: rest -> + begin + let nenv = + match st.st_label with + Anonymous -> anomaly "anonymous variable" + | Name id -> Environ.push_named (id,None,st.st_it) env in + let pr_sep = if sep then pr_coma () else mt () in + spc() ++ pr_sep ++ + pr_statement pr_constr env st ++ + print_vars pconstr gtyp nenv true _be _have rest + end + | (Hprop _ :: _) as rest -> + let _st = if _be then + str "be such that" + else + str "such that" in + spc() ++ _st ++ print_hyps pconstr gtyp env false _be _have rest + | [] -> mt () + +let pr_suffices_clause env (hyps,c) = + print_hyps pr_constr _I env false false "to have" hyps ++ spc () ++ + str "to show" ++ spc () ++ pr_or_thesis pr_constr env c + +let pr_elim_type = function + ET_Case_analysis -> str "cases" + | ET_Induction -> str "induction" + +let pr_casee env =function + Real c -> str "on" ++ spc () ++ pr_constr env c + | Virtual cut -> str "of" ++ spc () ++ pr_cut (pr_statement pr_constr) env cut + +let pr_side = function + Lhs -> str "=~" + | Rhs -> str "~=" + +let rec pr_bare_proof_instr _then _thus env = function + | Pescape -> str "escape" + | Pthen i -> pr_bare_proof_instr true _thus env i + | Pthus i -> pr_bare_proof_instr _then true env i + | Phence i -> pr_bare_proof_instr true true env i + | Pcut c -> + begin + match _then,_thus with + false,false -> str "have" ++ spc () ++ + pr_cut (pr_statement (pr_or_thesis pr_constr)) env c + | false,true -> str "thus" ++ spc () ++ + pr_cut (pr_statement (pr_or_thesis pr_constr)) env c + | true,false -> str "then" ++ spc () ++ + pr_cut (pr_statement (pr_or_thesis pr_constr)) env c + | true,true -> str "hence" ++ spc () ++ + pr_cut (pr_statement (pr_or_thesis pr_constr)) env c + end + | Psuffices c -> + str "suffices" ++ pr_cut pr_suffices_clause env c + | Prew (sid,c) -> + (if _thus then str "thus" else str " ") ++ spc () ++ + pr_side sid ++ spc () ++ pr_cut (pr_statement pr_constr) env c + | Passume hyps -> + str "assume" ++ print_hyps pr_constr _I env false false "we have" hyps + | Plet hyps -> + str "let" ++ print_vars pr_constr _I env false true "let" hyps + | Pclaim st -> + str "claim" ++ spc () ++ pr_statement pr_constr env st + | Pfocus st -> + str "focus on" ++ spc () ++ pr_statement pr_constr env st + | Pconsider (id,hyps) -> + str "consider" ++ print_vars pr_constr _I env false false "consider" hyps + ++ spc () ++ str "from " ++ pr_constr env id + | Pgiven hyps -> + str "given" ++ print_vars pr_constr _I env false false "given" hyps + | Ptake witl -> + str "take" ++ spc () ++ + prlist_with_sep pr_coma (pr_constr env) witl + | Pdefine (id,args,body) -> + str "define" ++ spc () ++ pr_id id ++ spc () ++ + prlist_with_sep spc + (fun st -> str "(" ++ + pr_statement pr_constr env st ++ str ")") args ++ spc () ++ + str "as" ++ (pr_constr env body) + | Pcast (id,typ) -> + str "reconsider" ++ spc () ++ + pr_or_thesis (fun _ -> pr_id) env id ++ spc () ++ + str "as" ++ spc () ++ (pr_constr env typ) + | Psuppose hyps -> + str "suppose" ++ + print_hyps pr_constr _I env false false "we have" hyps + | Pcase (params,pat,hyps) -> + str "suppose it is" ++ spc () ++ pr_pat pat ++ + (if params = [] then mt () else + (spc () ++ str "with" ++ spc () ++ + prlist_with_sep spc + (fun st -> str "(" ++ + pr_statement pr_constr env st ++ str ")") params ++ spc ())) + ++ + (if hyps = [] then mt () else + (spc () ++ str "and" ++ + print_hyps (pr_or_thesis pr_constr) type_or_thesis + env false false "we have" hyps)) + | Pper (et,c) -> + str "per" ++ spc () ++ pr_elim_type et ++ spc () ++ + pr_casee env c + | Pend (B_elim et) -> str "end" ++ spc () ++ pr_elim_type et + | _ -> anomaly "unprintable instruction" + +let pr_emph = function + 0 -> str " " + | 1 -> str "* " + | 2 -> str "** " + | 3 -> str "*** " + | _ -> anomaly "unknown emphasis" + +let pr_proof_instr env instr = + pr_emph instr.emph ++ spc () ++ + pr_bare_proof_instr false false env instr.instr + diff --git a/plugins/decl_mode/ppdecl_proof.mli b/plugins/decl_mode/ppdecl_proof.mli new file mode 100644 index 0000000000..fd6fb66376 --- /dev/null +++ b/plugins/decl_mode/ppdecl_proof.mli @@ -0,0 +1,2 @@ + +val pr_proof_instr : Environ.env -> Decl_expr.proof_instr -> Pp.std_ppcmds diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 8a0f02d27e..7f4acb8564 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -18,32 +18,6 @@ open Tactics open Tacticals open Libnames -(* -let old_search=ref !Auto.searchtable - -(* I use this solution as a means to know whether hints have changed, -but this prevents the GC from collecting the previous table, -resulting in some limited space wasting*) - -let update_flags ()= - if not ( !Auto.searchtable == !old_search ) then - begin - old_search:=!Auto.searchtable; - let predref=ref Names.KNpred.empty in - let f p_a_t = - match p_a_t.Auto.code with - Auto.Unfold_nth (ConstRef kn)-> - predref:=Names.KNpred.add kn !predref - | _ ->() in - let g _ l=List.iter f l in - let h _ hdb=Auto.Hint_db.iter g hdb in - Util.Stringmap.iter h !Auto.searchtable; - red_flags:= - Closure.RedFlags.red_add_transparent - Closure.betaiotazeta (Names.Idpred.full,!predref) - end -*) - let update_flags ()= let predref=ref Names.Cpred.empty in let f coe= @@ -61,7 +35,7 @@ let ground_tac solver startseq gl= update_flags (); let rec toptac skipped seq gl= if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 - then Pp.msgnl (Printer.pr_goal (sig_it gl)); + then Pp.msgnl (Printer.pr_goal gl); tclORELSE (axiom_tac seq.gl seq) begin try diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index e2cad94495..bef89909de 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -35,7 +35,7 @@ let observennl strm = let do_observe_tac s tac g = try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v with e -> - let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in + let goal = begin try (Printer.pr_goal g) with _ -> assert false end in msgnl (str "observation "++ s++str " raised exception " ++ Cerrors.explain_exn e ++ str " on goal " ++ goal ); raise e;; diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 0f048f59a0..ff7089613f 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -180,48 +180,9 @@ let save with_clean id const (locality,kind) hook = - -let extract_pftreestate pts = - let pfterm,subgoals = Refiner.extract_open_pftreestate pts in - let tpfsigma = Refiner.evc_of_pftreestate pts in - let exl = Evarutil.non_instantiated tpfsigma in - if subgoals <> [] or exl <> [] then - Util.errorlabstrm "extract_proof" - (if subgoals <> [] then - str "Attempt to save an incomplete proof" - else - str "Attempt to save a proof with existential variables still non-instantiated"); - let env = Global.env_of_context (Refiner.proof_of_pftreestate pts).Proof_type.goal.Evd.evar_hyps in - env,tpfsigma,pfterm - - -let nf_betaiotazeta = - let clos_norm_flags flgs env sigma t = - Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags Closure.betaiotazeta - -let nf_betaiota = - let clos_norm_flags flgs env sigma t = - Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags Closure.betaiota - -let cook_proof do_reduce = - let pfs = Pfedit.get_pftreestate () -(* and ident = Pfedit.get_current_proof_name () *) - and (ident,strength,concl,hook) = Pfedit.current_proof_statement () in - let env,sigma,pfterm = extract_pftreestate pfs in - let pfterm = - if do_reduce - then nf_betaiota env sigma pfterm - else pfterm - in - (ident, - ({ const_entry_body = pfterm; - const_entry_type = Some concl; - const_entry_opaque = false; - const_entry_boxed = false}, - strength, hook)) - +let cook_proof _ = + let (id,(entry,_,strength,hook)) = Pfedit.cook_proof (fun _ -> ()) in + (id,(entry,strength,hook)) let new_save_named opacity = let id,(const,persistence,hook) = cook_proof true in diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 6f6607fccc..c48dff0c63 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -50,15 +50,8 @@ val jmeq_refl : unit -> Term.constr (* [save_named] is a copy of [Command.save_named] but uses [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast] - - - - DON'T USE IT if you cannot ensure that there is no VMcast in the proof - *) -(* val nf_betaiotazeta : Reductionops.reduction_function *) - val new_save_named : bool -> unit val save : bool -> identifier -> Entries.definition_entry -> Decl_kinds.goal_kind -> diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 8c22265d66..28de815ca0 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -60,7 +60,7 @@ let observennl strm = let do_observe_tac s tac g = - let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in + let goal = begin try (Printer.pr_goal g) with _ -> assert false end in try let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v with e -> diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 1eae097189..8dc660b421 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -85,7 +85,7 @@ let rec print_debug_queue e = let do_observe_tac s tac g = - let goal = Printer.pr_goal (sig_it g) in + let goal = Printer.pr_goal g in let lmsg = (str "recdef ") ++ (str s) in Queue.add (lmsg,goal) debug_queue; try @@ -376,7 +376,7 @@ let rec mk_intros_and_continue thin_intros (extra_eqn:bool) (fun g1 -> let ty_teq = pf_type_of g1 (mkVar teq) in let teq_lhs,teq_rhs = - let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal (sig_it g1) ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in + let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal g1 ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in args.(1),args.(2) in cont_function (mkVar teq::eqs) (replace_term teq_lhs teq_rhs expr) g1 @@ -884,9 +884,9 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a end let get_current_subgoals_types () = - let pts = get_pftreestate () in - let _,subs = extract_open_pftreestate pts in - List.map snd ((* List.sort (fun (x,_) (y,_) -> x -y ) *)subs ) + let p = Proof_global.give_me_the_proof () in + let { Evd.it=sgs ; sigma=sigma } = Proof.V82.subgoals p in + List.map (Goal.V82.abstract_type sigma) sgs let build_and_l l = let and_constr = Coqlib.build_coq_and () in diff --git a/plugins/pluginsbyte.itarget b/plugins/pluginsbyte.itarget index 7ca8020dc1..c0237ecf70 100644 --- a/plugins/pluginsbyte.itarget +++ b/plugins/pluginsbyte.itarget @@ -21,3 +21,4 @@ syntax/r_syntax_plugin.cma syntax/string_syntax_plugin.cma syntax/z_syntax_plugin.cma quote/quote_plugin.cma +decl_mode/decl_mode_plugin.cma diff --git a/plugins/pluginsopt.itarget b/plugins/pluginsopt.itarget index 5206271157..26b3f90842 100644 --- a/plugins/pluginsopt.itarget +++ b/plugins/pluginsopt.itarget @@ -21,3 +21,4 @@ syntax/r_syntax_plugin.cmxa syntax/string_syntax_plugin.cmxa syntax/z_syntax_plugin.cmxa quote/quote_plugin.cmxa +decl_mode/decl_mode_plugin.cmxa diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 2e4d07d633..ce65a45ec8 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -111,7 +111,6 @@ open Pattern open Matching open Tacmach open Tactics -open Proof_trees open Tacexpr (*i*) diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml index 1e3765da6c..fdf3a9bd9d 100644 --- a/plugins/ring/ring.ml +++ b/plugins/ring/ring.ml @@ -21,7 +21,6 @@ open Reductionops open Tacticals open Tacexpr open Tacmach -open Proof_trees open Printer open Equality open Vernacinterp diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 23cb07050a..06313e8fe7 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -267,14 +267,13 @@ open Pp let rtauto_tac gls= Coqlib.check_required_library ["Coq";"rtauto";"Rtauto"]; let gamma={next=1;env=[]} in - let gl=gls.it.evar_concl in + let gl=pf_concl gls in let _= if Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) gl <> InProp then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in let glf=make_form gamma gls gl in - let hyps=make_hyps gamma gls [gl] - (Environ.named_context_of_val gls.it.evar_hyps) in + let hyps=make_hyps gamma gls [gl] (pf_hyps gls) in let formula= List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in let search_fun = diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4 index 490ae89db0..d6dece458b 100644 --- a/plugins/setoid_ring/newring.ml4 +++ b/plugins/setoid_ring/newring.ml4 @@ -188,8 +188,10 @@ let ltac_record flds = let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c) let dummy_goal env = - {Evd.it = Evd.make_evar (named_context_val env) mkProp; - Evd.sigma = Evd.empty} + let (gl,_,sigma) = + Goal.V82.mk_goal Evd.empty (named_context_val env) mkProp Store.empty in + {Evd.it = gl; + Evd.sigma = sigma} let exec_tactic env n f args = let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in diff --git a/plugins/subtac/eterm.ml b/plugins/subtac/eterm.ml index f1bdd64092..bfa2d47413 100644 --- a/plugins/subtac/eterm.ml +++ b/plugins/subtac/eterm.ml @@ -33,6 +33,10 @@ type oblinfo = ev_tac: tactic option; ev_deps: Intset.t } +(* spiwack: Store field for internalizing ev_tac in evar_infos' evar_extra. *) +open Store.Field +let evar_tactic = Store.field () + (** Substitute evar references in t using De Bruijn indices, where n binders were passed through. *) @@ -210,7 +214,7 @@ let eterm_obligations env name isevars evm fs ?status t ty = | Some s -> s, None | None -> Define true, None in - let tac = match ev.evar_extra with + let tac = match evar_tactic.get ev.evar_extra with | Some t -> if Dyn.tag t = "tactic" then Some (Tacinterp.interp diff --git a/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml index 0eba0f6336..e649ad97be 100644 --- a/plugins/subtac/subtac.ml +++ b/plugins/subtac/subtac.ml @@ -50,7 +50,7 @@ open Tacinterp open Tacexpr let solve_tccs_in_type env id isevars evm c typ = - if not (evm = Evd.empty) then + if not (Evd.is_empty evm) then let stmt_id = Nameops.add_suffix id "_stmt" in let obls, _, c', t' = eterm_obligations env stmt_id !isevars evm 0 ~status:Expand c typ in match Subtac_obligations.add_definition stmt_id ~term:c' typ obls with @@ -246,5 +246,5 @@ let subtac (loc, command) = raise e) | e -> - msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e); + msg_warning (str "Uncaught exception: " ++ Cerrors.explain_exn e); raise e diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml index 1424618f00..181d0fa72d 100644 --- a/plugins/subtac/subtac_obligations.ml +++ b/plugins/subtac/subtac_obligations.ml @@ -489,6 +489,7 @@ and solve_obligation_by_tac prg obls i tac = | Stdpp.Exc_located(_, Refiner.FailError (_, s)) | Refiner.FailError (_, s) -> user_err_loc (obl.obl_location, "solve_obligation", Lazy.force s) + | Util.Anomaly _ as e -> raise e | e -> false and solve_prg_obligations prg tac = diff --git a/plugins/xml/dumptree.ml4 b/plugins/xml/dumptree.ml4 index 9419ba597e..d20f9f9b67 100644 --- a/plugins/xml/dumptree.ml4 +++ b/plugins/xml/dumptree.ml4 @@ -56,13 +56,11 @@ let pr_rule_xml pr = function hov 2 (str "" ++ fnl () ++ begin match cmpd with Tactic (texp, _) -> pr_tactic_xml texp - | Proof_instr (_,instr) -> pr_proof_instr_xml instr end ++ fnl () ++ pr subtree ) ++ fnl () ++ str "" | Daimon -> str "" | Decl_proof _ -> str "" -(* | Change_evars -> str ""*) ;; let pr_var_decl_xml env (id,c,typ) = @@ -115,11 +113,11 @@ let pr_subgoal_metas_xml metas env= List.fold_left (++) (mt ()) (List.map pr_one metas) ;; -let pr_goal_xml g = - let env = try evar_unfiltered_env g with _ -> empty_env in - if g.evar_extra = None then +let pr_goal_xml sigma g = + let env = try Goal.V82.unfiltered_env sigma g with _ -> empty_env in + if Decl_mode.try_get_info sigma g = None then (hov 2 (str "" ++ fnl () ++ str "" ++ (pr_context_xml env)) ++ fnl () ++ str "") @@ -129,23 +127,9 @@ let pr_goal_xml g = fnl () ++ str "") ;; -let rec print_proof_xml sigma osign pf = - let hyps = Environ.named_context_of_val pf.goal.evar_hyps in - let hyps' = thin_sign osign hyps in - match pf.ref with - | None -> hov 2 (str "" ++ fnl () ++ (pr_goal_xml {pf.goal with evar_hyps=hyps'})) ++ fnl () ++ str "" - | Some(r,spfl) -> - hov 2 (str "" ++ fnl () ++ - (pr_goal_xml {pf.goal with evar_hyps=hyps'}) ++ fnl () ++ (pr_rule_xml (print_proof_xml sigma osign) r) ++ - (List.fold_left (fun x y -> x ++ fnl () ++ y) (mt ()) (List.map (print_proof_xml sigma hyps) spfl))) ++ fnl () ++ str "" -;; - let print_proof_xml () = - let pp = print_proof_xml Evd.empty Sign.empty_named_context - (Tacmach.proof_of_pftreestate (Refiner.top_of_tree (Pfedit.get_pftreestate ()))) - in - msgnl pp -;; + Util.anomaly "Dump Tree command not supported in this version." + VERNAC COMMAND EXTEND DumpTree [ "Dump" "Tree" ] -> [ print_proof_xml () ] diff --git a/plugins/xml/proof2aproof.ml b/plugins/xml/proof2aproof.ml index 1beabf26ca..c7b8b556ed 100644 --- a/plugins/xml/proof2aproof.ml +++ b/plugins/xml/proof2aproof.ml @@ -94,83 +94,9 @@ module ProofTreeHash = let extract_open_proof sigma pf = - let module PT = Proof_type in - let module L = Logic in - let evd = ref (Evd.create_evar_defs sigma) in - let proof_tree_to_constr = ProofTreeHash.create 503 in - let proof_tree_to_flattened_proof_tree = ProofTreeHash.create 503 in - let unshared_constrs = ref S.empty in - let rec proof_extractor vl node = - let constr = - match node with - {PT.ref=Some(PT.Prim _,_)} as pf -> - L.prim_extractor proof_extractor vl pf - - | {PT.ref=Some(PT.Nested (_,hidden_proof),spfl)} -> - let sgl,v = Refiner.frontier hidden_proof in - let flat_proof = v spfl in - ProofTreeHash.add proof_tree_to_flattened_proof_tree node flat_proof ; - proof_extractor vl flat_proof - - | {PT.ref=None;PT.goal=goal} -> - let visible_rels = - Util.map_succeed - (fun id -> - (* Section variables are in the [id] list but are not *) - (* lambda abstracted in the term [vl] *) - try let n = Logic.proof_variable_index id vl in (n,id) - with Not_found -> failwith "caught") -(*CSC: the above function must be modified such that when it is found *) -(*CSC: it becomes a Rel; otherwise a Var. Then it can be already used *) -(*CSC: as the evar_instance. Ordering the instance becomes useless (it *) -(*CSC: will already be ordered. *) - (Termops.ids_of_named_context - (Environ.named_context_of_val goal.Evd.evar_hyps)) in - let sorted_rels = - Sort.list (fun (n1,_) (n2,_) -> n1 < n2 ) visible_rels in - let context = - let l = - List.map - (fun (_,id) -> Sign.lookup_named id - (Environ.named_context_of_val goal.Evd.evar_hyps)) - sorted_rels in - Environ.val_of_named_context l - in -(*CSC: the section variables in the right order must be added too *) - let evar_instance = List.map (fun (n,_) -> Term.mkRel n) sorted_rels in - (* let env = Global.env_of_context context in *) - let evd',evar = - Evarutil.new_evar_instance context !evd goal.Evd.evar_concl - evar_instance in - evd := evd' ; - evar - - | _ -> Util.anomaly "Bug : a case has been forgotten in proof_extractor" - in - let unsharedconstr = - let evar_nf_constr = - nf_evar ( !evd) - ~preserve:(function e -> S.mem e !unshared_constrs) constr - in - Unshare.unshare - ~already_unshared:(function e -> S.mem e !unshared_constrs) - evar_nf_constr - in -(*CSC: debugging stuff to be removed *) -if ProofTreeHash.mem proof_tree_to_constr node then - Pp.ppnl (Pp.(++) (Pp.str "#DUPLICATE INSERTION: ") - (Tactic_printer.print_proof ( !evd) [] node)) ; - ProofTreeHash.add proof_tree_to_constr node unsharedconstr ; - unshared_constrs := S.add unsharedconstr !unshared_constrs ; - unsharedconstr - in - let unshared_pf = unshare_proof_tree pf in - let pfterm = proof_extractor [] unshared_pf in - (pfterm, !evd, proof_tree_to_constr, proof_tree_to_flattened_proof_tree, - unshared_pf) -;; + (* Deactivated and candidate for removal. (Apr. 2010) *) + () let extract_open_pftreestate pts = - extract_open_proof (Refiner.evc_of_pftreestate pts) - (Tacmach.proof_of_pftreestate pts) -;; + (* Deactivated and candidate for removal. (Apr. 2010) *) + () diff --git a/plugins/xml/proofTree2Xml.ml4 b/plugins/xml/proofTree2Xml.ml4 index 3f1e0a630b..dcfa997923 100644 --- a/plugins/xml/proofTree2Xml.ml4 +++ b/plugins/xml/proofTree2Xml.ml4 @@ -161,10 +161,12 @@ Pp.ppnl (Pp.(++) (Pp.str let of_attribute = ("name",tacname)::("script",tac)::of_attribute in (****** le but *) - let {Evd.evar_concl=concl; - Evd.evar_hyps=hyps}=goal in + + let concl = Goal.V82.concl sigma goal in + let hyps = Goal.V82.hyps sigma goal in let env = Global.env_of_context hyps in + let xgoal = X.xml_nempty "Goal" [] (constr_to_xml concl sigma env) in @@ -188,9 +190,6 @@ Pp.ppnl (Pp.(++) (Pp.str [<(build_hyps new_hyps) ; (aux flat_proof nhyps)>] end - | {PT.ref=Some((PT.Nested(PT.Proof_instr (_,_),_)|PT.Decl_proof _),nodes)} -> - Util.anomaly "Not Implemented" - | {PT.ref=Some(PT.Daimon,_)} -> X.xml_empty "Hidden_open_goal" of_attribute diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml index b3b2e26549..8a095bb245 100644 --- a/plugins/xml/xmlcommand.ml +++ b/plugins/xml/xmlcommand.ml @@ -551,34 +551,7 @@ let print_ref qid fn = (* where dest is either None (for stdout) or (Some filename) *) (* pretty prints via Xml.pp the proof in progress on dest *) let show_pftreestate internal fn (kind,pftst) id = - let pf = Tacmach.proof_of_pftreestate pftst in - let typ = (Proof_trees.goal_of_proof pf).Evd.evar_concl in - let val0,evar_map,proof_tree_to_constr,proof_tree_to_flattened_proof_tree, - unshared_pf - = - Proof2aproof.extract_open_pftreestate pftst in - let env = Global.env () in - let obj = - mk_current_proof_obj (fst kind = Decl_kinds.Local) id val0 typ evar_map env in - let uri = - match kind with - Decl_kinds.Local, _ -> - let uri = - "cic:/" ^ String.concat "/" - (Cic2acic.token_list_of_path (Lib.cwd ()) id Cic2acic.TVariable) - in - let kind_of_var = "VARIABLE","LocalFact" in - if not internal then print_object_kind uri kind_of_var; - uri - | Decl_kinds.Global, _ -> - let uri = Cic2acic.uri_of_declaration id Cic2acic.TConstant in - if not internal then print_object_kind uri (kind_of_global_goal kind); - uri - in - print_object uri obj evar_map - (Some (Tacmach.evc_of_pftreestate pftst,unshared_pf,proof_tree_to_constr, - proof_tree_to_flattened_proof_tree)) fn -;; + Util.anomaly "Xmlcommand.show_pftreestate is not supported in this version." let show fn = let pftst = Pfedit.get_pftreestate () in diff --git a/pretyping/clenv.ml b/pretyping/clenv.ml deleted file mode 100644 index 7cbaf124a7..0000000000 --- a/pretyping/clenv.ml +++ /dev/null @@ -1,478 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* clrec t - | Prod (na,t,u) -> - let mv = new_meta () in - let dep = dependent (mkRel 1) u in - let na' = if dep then na else Anonymous in - let e' = meta_declare mv t ~name:na' cl.evd in - let concl = if dep then subst1 (mkMeta mv) u else u in - let def = applist (cl.templval.rebus,[mkMeta mv]) in - { templval = mk_freelisted def; - templtyp = mk_freelisted concl; - evd = e'; - env = cl.env } - | _ -> raise NotExtensibleClause - in clrec typ - -(* Instantiate the first [bound] products of [t] with metas (all products if - [bound] is [None]; unfold local defs *) - -let clenv_environments evd bound t = - let rec clrec (e,metas) n t = - match n, kind_of_term t with - | (Some 0, _) -> (e, List.rev metas, t) - | (n, Cast (t,_,_)) -> clrec (e,metas) n t - | (n, Prod (na,t1,t2)) -> - let mv = new_meta () in - let dep = dependent (mkRel 1) t2 in - let na' = if dep then na else Anonymous in - let e' = meta_declare mv t1 ~name:na' e in - clrec (e', (mkMeta mv)::metas) (Option.map ((+) (-1)) n) - (if dep then (subst1 (mkMeta mv) t2) else t2) - | (n, LetIn (na,b,_,t)) -> clrec (e,metas) n (subst1 b t) - | (n, _) -> (e, List.rev metas, t) - in - clrec (evd,[]) bound t - -(* Instantiate the first [bound] products of [t] with evars (all products if - [bound] is [None]; unfold local defs *) - -let clenv_environments_evars env evd bound t = - let rec clrec (e,ts) n t = - match n, kind_of_term t with - | (Some 0, _) -> (e, List.rev ts, t) - | (n, Cast (t,_,_)) -> clrec (e,ts) n t - | (n, Prod (na,t1,t2)) -> - let e',constr = Evarutil.new_evar e env t1 in - let dep = dependent (mkRel 1) t2 in - clrec (e', constr::ts) (Option.map ((+) (-1)) n) - (if dep then (subst1 constr t2) else t2) - | (n, LetIn (na,b,_,t)) -> clrec (e,ts) n (subst1 b t) - | (n, _) -> (e, List.rev ts, t) - in - clrec (evd,[]) bound t - -let clenv_conv_leq env sigma t c bound = - let ty = Retyping.get_type_of env sigma c in - let evd = Evd.create_goal_evar_defs sigma in - let evars,args,_ = clenv_environments_evars env evd (Some bound) ty in - let evars = Evarconv.the_conv_x_leq env t (applist (c,args)) evars in - let evars = Evarconv.consider_remaining_unif_problems env evars in - let args = List.map (whd_evar evars) args in - check_evars env sigma evars (applist (c,args)); - args - -let mk_clenv_from_env environ sigma n (c,cty) = - let evd = create_goal_evar_defs sigma in - let (evd,args,concl) = clenv_environments evd n cty in - { templval = mk_freelisted (match args with [] -> c | _ -> applist (c,args)); - templtyp = mk_freelisted concl; - evd = evd; - env = environ } - -let mk_clenv_from_n gls n (c,cty) = - mk_clenv_from_env (Global.env_of_context gls.it.evar_hyps) gls.sigma n (c, cty) - -let mk_clenv_from gls = mk_clenv_from_n gls None - -let mk_clenv_rename_from_n gls n (c,t) = - mk_clenv_from_n gls n (c,rename_bound_vars_as_displayed [] t) - -let mk_clenv_type_of gls t = mk_clenv_from gls (t,pf_type_of gls t) - -(******************************************************************) - -(* [mentions clenv mv0 mv1] is true if mv1 is defined and mentions - * mv0, or if one of the free vars on mv1's freelist mentions - * mv0 *) - -let mentions clenv mv0 = - let rec menrec mv1 = - mv0 = mv1 || - let mlist = - try match meta_opt_fvalue clenv.evd mv1 with - | Some (b,_) -> b.freemetas - | None -> Metaset.empty - with Not_found -> Metaset.empty in - meta_exists menrec mlist - in menrec - -let error_incompatible_inst clenv mv = - let na = meta_name clenv.evd mv in - match na with - Name id -> - errorlabstrm "clenv_assign" - (str "An incompatible instantiation has already been found for " ++ - pr_id id) - | _ -> - anomaly "clenv_assign: non dependent metavar already assigned" - -(* TODO: replace by clenv_unify (mkMeta mv) rhs ? *) -let clenv_assign mv rhs clenv = - let rhs_fls = mk_freelisted rhs in - if meta_exists (mentions clenv mv) rhs_fls.freemetas then - error "clenv_assign: circularity in unification"; - try - if meta_defined clenv.evd mv then - if not (eq_constr (fst (meta_fvalue clenv.evd mv)).rebus rhs) then - error_incompatible_inst clenv mv - else - clenv - else - let st = (ConvUpToEta 0,TypeNotProcessed) in - {clenv with evd = meta_assign mv (rhs_fls.rebus,st) clenv.evd} - with Not_found -> - error "clenv_assign: undefined meta" - - - -(* [clenv_dependent hyps_only clenv] - * returns a list of the metavars which appear in the template of clenv, - * and which are dependent, This is computed by taking the metavars in cval, - * in right-to-left order, and collecting the metavars which appear - * in their types, and adding in all the metavars appearing in the - * type of clenv. - * If [hyps_only] then metavariables occurring in the type are _excluded_ *) - -(* [clenv_metavars clenv mv] - * returns a list of the metavars which appear in the type of - * the metavar mv. The list is unordered. *) - -let clenv_metavars evd mv = - (mk_freelisted (meta_instance evd (meta_ftype evd mv))).freemetas - -let dependent_metas clenv mvs conclmetas = - List.fold_right - (fun mv deps -> - Metaset.union deps (clenv_metavars clenv.evd mv)) - mvs conclmetas - -let duplicated_metas c = - let rec collrec (one,more as acc) c = - match kind_of_term c with - | Meta mv -> if List.mem mv one then (one,mv::more) else (mv::one,more) - | _ -> fold_constr collrec acc c - in - snd (collrec ([],[]) c) - -let clenv_dependent hyps_only clenv = - let mvs = undefined_metas clenv.evd in - let ctyp_mvs = (mk_freelisted (clenv_type clenv)).freemetas in - let deps = dependent_metas clenv mvs ctyp_mvs in - let nonlinear = duplicated_metas (clenv_value clenv) in - (* Make the assumption that duplicated metas have internal dependencies *) - List.filter - (fun mv -> if Metaset.mem mv deps - then not (hyps_only && Metaset.mem mv ctyp_mvs) - else List.mem mv nonlinear) - mvs - -let clenv_missing ce = clenv_dependent true ce - -(******************************************************************) - -let clenv_unify allow_K ?(flags=default_unify_flags) cv_pb t1 t2 clenv = - { clenv with - evd = w_unify allow_K ~flags:flags clenv.env cv_pb t1 t2 clenv.evd } - -let clenv_unify_meta_types ?(flags=default_unify_flags) clenv = - { clenv with evd = w_unify_meta_types ~flags:flags clenv.env clenv.evd } - -let clenv_unique_resolver allow_K ?(flags=default_unify_flags) clenv gl = - if isMeta (fst (whd_stack clenv.evd clenv.templtyp.rebus)) then - clenv_unify allow_K CUMUL ~flags:flags (clenv_type clenv) (pf_concl gl) - (clenv_unify_meta_types ~flags:flags clenv) - else - clenv_unify allow_K CUMUL ~flags:flags - (meta_reducible_instance clenv.evd clenv.templtyp) (pf_concl gl) clenv - -(* [clenv_pose_metas_as_evars clenv dep_mvs] - * For each dependent evar in the clause-env which does not have a value, - * pose a value for it by constructing a fresh evar. We do this in - * left-to-right order, so that every evar's type is always closed w.r.t. - * metas. - - * Node added 14/4/08 [HH]: before this date, evars were collected in - clenv_dependent by collect_metas in the fold_constr order which is - (almost) the left-to-right order of dependencies in term. However, - due to K-redexes, collect_metas was sometimes missing some metas. - The call to collect_metas has been replaced by a call to - undefined_metas, but then the order was the one of definition of - the metas (numbers in increasing order) which is _not_ the - dependency order when a clenv_fchain occurs (because clenv_fchain - plugs a term with a list of consecutive metas in place of a - a priori - - arbitrary metavariable belonging to another sequence of consecutive metas: - e.g., clenv_fchain may plug (H ?1 ?2) at the position ?6 of - (nat_ind ?3 ?4 ?5 ?6), leading to a dependency order 3<4<5<1<2). - To ensure the dependency order, we check that the type of each meta - to pose is already meta-free, otherwise we postpone the transformation, - hoping that no cycle may happen. - - Another approach could have been to use decimal numbers for metas so that - in the example above, (H ?1 ?2) would have been renumbered (H ?6.1 ?6.2) - then making the numeric order match the dependency order. -*) - -let clenv_pose_metas_as_evars clenv dep_mvs = - let rec fold clenv = function - | [] -> clenv - | mv::mvs -> - let ty = clenv_meta_type clenv mv in - (* Postpone the evar-ization if dependent on another meta *) - (* This assumes no cycle in the dependencies - is it correct ? *) - if occur_meta ty then fold clenv (mvs@[mv]) - else - let (evd,evar) = - new_evar clenv.evd (cl_env clenv) ~src:(dummy_loc,GoalEvar) ty in - let clenv = clenv_assign mv evar {clenv with evd=evd} in - fold clenv mvs in - fold clenv dep_mvs - -let evar_clenv_unique_resolver = clenv_unique_resolver - -(******************************************************************) - -let connect_clenv gls clenv = - { clenv with - evd = evars_reset_evd gls.sigma clenv.evd; - env = Global.env_of_context gls.it.evar_hyps } - -(* [clenv_fchain mv clenv clenv'] - * - * Resolves the value of "mv" (which must be undefined) in clenv to be - * the template of clenv' be the value "c", applied to "n" fresh - * metavars, whose types are chosen by destructing "clf", which should - * be a clausale forme generated from the type of "c". The process of - * resolution can cause unification of already-existing metavars, and - * of the fresh ones which get created. This operation is a composite - * of operations which pose new metavars, perform unification on - * terms, and make bindings. - - Otherwise said, from - - [clenv] = [env;sigma;metas |- c:T] - [clenv'] = [env';sigma';metas' |- d:U] - [mv] = [mi] of type [Ti] in [metas] - - then, if the unification of [Ti] and [U] produces map [rho], the - chaining is [env';sigma';rho'(metas),rho(metas') |- c:rho'(T)] for - [rho'] being [rho;mi:=d]. - - In particular, it assumes that [env'] and [sigma'] extend [env] and [sigma]. -*) -let clenv_fchain ?(allow_K=true) ?(flags=default_unify_flags) mv clenv nextclenv = - (* Add the metavars of [nextclenv] to [clenv], with their name-environment *) - let clenv' = - { templval = clenv.templval; - templtyp = clenv.templtyp; - evd = - evar_merge (meta_merge clenv.evd nextclenv.evd) clenv.evd; - env = nextclenv.env } in - (* unify the type of the template of [nextclenv] with the type of [mv] *) - let clenv'' = - clenv_unify allow_K ~flags:flags CUMUL - (clenv_term clenv' nextclenv.templtyp) - (clenv_meta_type clenv' mv) - clenv' in - (* assign the metavar *) - let clenv''' = - clenv_assign mv (clenv_term clenv' nextclenv.templval) clenv'' - in - clenv''' - -(***************************************************************) -(* Bindings *) - -type arg_bindings = constr explicit_bindings - -(* [clenv_independent clenv] - * returns a list of metavariables which appear in the term cval, - * and which are not dependent. That is, they do not appear in - * the types of other metavars which are in cval, nor in the type - * of cval, ctyp. *) - -let clenv_independent clenv = - let mvs = collect_metas (clenv_value clenv) in - let ctyp_mvs = (mk_freelisted (clenv_type clenv)).freemetas in - let deps = dependent_metas clenv mvs ctyp_mvs in - List.filter (fun mv -> not (Metaset.mem mv deps)) mvs - -let check_bindings bl = - match list_duplicates (List.map pi2 bl) with - | NamedHyp s :: _ -> - errorlabstrm "" - (str "The variable " ++ pr_id s ++ - str " occurs more than once in binding list."); - | AnonHyp n :: _ -> - errorlabstrm "" - (str "The position " ++ int n ++ - str " occurs more than once in binding list.") - | [] -> () - -let meta_of_binder clause loc mvs = function - | NamedHyp s -> meta_with_name clause.evd s - | AnonHyp n -> - try List.nth mvs (n-1) - with (Failure _|Invalid_argument _) -> - errorlabstrm "" (str "No such binder.") - -let error_already_defined b = - match b with - | NamedHyp id -> - errorlabstrm "" - (str "Binder name \"" ++ pr_id id ++ - str"\" already defined with incompatible value.") - | AnonHyp n -> - anomalylabstrm "" - (str "Position " ++ int n ++ str" already defined.") - -let clenv_unify_binding_type clenv c t u = - if isMeta (fst (whd_stack clenv.evd u)) then - (* Not enough information to know if some subtyping is needed *) - CoerceToType, clenv, c - else - (* Enough information so as to try a coercion now *) - try - let evd,c = w_coerce_to_type (cl_env clenv) clenv.evd c t u in - TypeProcessed, { clenv with evd = evd }, c - with - | PretypeError (_,NotClean _) as e -> raise e - | e when precatchable_exception e -> - TypeNotProcessed, clenv, c - -let clenv_assign_binding clenv k c = - let k_typ = clenv_hnf_constr clenv (clenv_meta_type clenv k) in - let c_typ = nf_betaiota clenv.evd (clenv_get_type_of clenv c) in - let status,clenv',c = clenv_unify_binding_type clenv c c_typ k_typ in - { clenv' with evd = meta_assign k (c,(UserGiven,status)) clenv'.evd } - -let clenv_match_args bl clenv = - if bl = [] then - clenv - else - let mvs = clenv_independent clenv in - check_bindings bl; - List.fold_left - (fun clenv (loc,b,c) -> - let k = meta_of_binder clenv loc mvs b in - if meta_defined clenv.evd k then - if eq_constr (fst (meta_fvalue clenv.evd k)).rebus c then clenv - else error_already_defined b - else - clenv_assign_binding clenv k c) - clenv bl - -let clenv_constrain_last_binding c clenv = - let all_mvs = collect_metas clenv.templval.rebus in - let k = - try list_last all_mvs - with Failure _ -> anomaly "clenv_constrain_with_bindings" in - clenv_assign_binding clenv k c - -let clenv_constrain_dep_args hyps_only bl clenv = - if bl = [] then - clenv - else - let occlist = clenv_dependent hyps_only clenv in - if List.length occlist = List.length bl then - List.fold_left2 clenv_assign_binding clenv occlist bl - else - errorlabstrm "" - (strbrk "Not the right number of missing arguments (expected " ++ - int (List.length occlist) ++ str ").") - -(****************************************************************) -(* Clausal environment for an application *) - -let make_clenv_binding_gen hyps_only n gls (c,t) = function - | ImplicitBindings largs -> - let clause = mk_clenv_from_n gls n (c,t) in - clenv_constrain_dep_args hyps_only largs clause - | ExplicitBindings lbind -> - let clause = mk_clenv_rename_from_n gls n (c,t) in - clenv_match_args lbind clause - | NoBindings -> - mk_clenv_from_n gls n (c,t) - -let make_clenv_binding_apply gls n = make_clenv_binding_gen true n gls -let make_clenv_binding = make_clenv_binding_gen false None - -(****************************************************************) -(* Pretty-print *) - -let pr_clenv clenv = - h 0 - (str"TEMPL: " ++ print_constr clenv.templval.rebus ++ - str" : " ++ print_constr clenv.templtyp.rebus ++ fnl () ++ - pr_evar_map clenv.evd) diff --git a/pretyping/clenv.mli b/pretyping/clenv.mli deleted file mode 100644 index 4f7ac40920..0000000000 --- a/pretyping/clenv.mli +++ /dev/null @@ -1,143 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* clausenv -> clausenv - -(* subject of clenv (instantiated) *) -val clenv_value : clausenv -> constr -(* type of clenv (instantiated) *) -val clenv_type : clausenv -> types -(* substitute resolved metas *) -val clenv_nf_meta : clausenv -> constr -> constr -(* type of a meta in clenv context *) -val clenv_meta_type : clausenv -> metavariable -> types - -val mk_clenv_from : evar_info sigma -> constr * types -> clausenv -val mk_clenv_from_n : - evar_info sigma -> int option -> constr * types -> clausenv -val mk_clenv_type_of : evar_info sigma -> constr -> clausenv -val mk_clenv_from_env : env -> evar_map -> int option -> constr * types -> clausenv - -(***************************************************************) -(* linking of clenvs *) - -val connect_clenv : evar_info sigma -> clausenv -> clausenv -val clenv_fchain : - ?allow_K:bool -> ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv - -(***************************************************************) -(* Unification with clenvs *) - -(* Unifies two terms in a clenv. The boolean is [allow_K] (see [Unification]) *) -val clenv_unify : - bool -> ?flags:unify_flags -> conv_pb -> constr -> constr -> clausenv -> clausenv - -(* unifies the concl of the goal with the type of the clenv *) -val clenv_unique_resolver : - bool -> ?flags:unify_flags -> clausenv -> evar_info sigma -> clausenv - -(* same as above ([allow_K=false]) but replaces remaining metas - with fresh evars if [evars_flag] is [true] *) -val evar_clenv_unique_resolver : - bool -> ?flags:unify_flags -> clausenv -> evar_info sigma -> clausenv - -val clenv_dependent : bool -> clausenv -> metavariable list - -val clenv_pose_metas_as_evars : clausenv -> metavariable list -> clausenv - -(***************************************************************) -(* Bindings *) - -type arg_bindings = constr explicit_bindings - -(* bindings where the key is the position in the template of the - clenv (dependent or not). Positions can be negative meaning to - start from the rightmost argument of the template. *) -val clenv_independent : clausenv -> metavariable list -val clenv_missing : clausenv -> metavariable list - -val clenv_constrain_last_binding : constr -> clausenv -> clausenv - -(* defines metas corresponding to the name of the bindings *) -val clenv_match_args : arg_bindings -> clausenv -> clausenv - -val clenv_unify_meta_types : ?flags:unify_flags -> clausenv -> clausenv - -(* start with a clenv to refine with a given term with bindings *) - -(* the arity of the lemma is fixed *) -(* the optional int tells how many prods of the lemma have to be used *) -(* use all of them if None *) -val make_clenv_binding_apply : - evar_info sigma -> int option -> constr * constr -> constr bindings -> - clausenv -val make_clenv_binding : - evar_info sigma -> constr * constr -> constr bindings -> clausenv - -(* [clenv_environments sigma n t] returns [sigma',lmeta,ccl] where - [lmetas] is a list of metas to be applied to a proof of [t] so that - it produces the unification pattern [ccl]; [sigma'] is [sigma] - extended with [lmetas]; if [n] is defined, it limits the size of - the list even if [ccl] is still a product; otherwise, it stops when - [ccl] is not a product; example: if [t] is [forall x y, x=y -> y=x] - and [n] is [None], then [lmetas] is [Meta n1;Meta n2;Meta n3] and - [ccl] is [Meta n1=Meta n2]; if [n] is [Some 1], [lmetas] is [Meta n1] - and [ccl] is [forall y, Meta n1=y -> y=Meta n1] *) -val clenv_environments : - evar_map -> int option -> types -> evar_map * constr list * types - -(* [clenv_environments_evars env sigma n t] does the same but returns - a list of Evar's defined in [env] and extends [sigma] accordingly *) -val clenv_environments_evars : - env -> evar_map -> int option -> types -> evar_map * constr list * types - -(* [clenv_conv_leq env sigma t c n] looks for c1...cn s.t. [t <= c c1...cn] *) -val clenv_conv_leq : - env -> evar_map -> types -> constr -> int -> constr list - -(* if the clause is a product, add an extra meta for this product *) -exception NotExtensibleClause -val clenv_push_prod : clausenv -> clausenv - -(***************************************************************) -(* Pretty-print *) -val pr_clenv : clausenv -> Pp.std_ppcmds - diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 24850b4baf..6d37cf80f5 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -150,12 +150,11 @@ let evars_to_metas sigma (emap, c) = (* The list of non-instantiated existential declarations *) let non_instantiated sigma = - let listev = to_list sigma in - List.fold_left - (fun l (ev,evi) -> - if evi.evar_body = Evar_empty then - ((ev,nf_evar_info sigma evi)::l) else l) - [] listev + List.rev begin + Evd.fold_undefined begin fun ev evi l -> + (ev,nf_evar_info sigma evi)::l + end sigma [] + end (**********************) (* Creating new evars *) @@ -478,6 +477,10 @@ type clear_dependency_error = exception ClearDependencyError of identifier * clear_dependency_error +open Store.Field + +let cleared = Store.field () + let rec check_and_clear_in_constr evdref err ids c = (* returns a new constr where all the evars have been 'cleaned' (ie the hypotheses ids have been removed from the contexts of @@ -539,6 +542,13 @@ let rec check_and_clear_in_constr evdref err ids c = let ev'= e_new_evar evdref env ~src:(evar_source evk !evdref) nconcl in evdref := Evd.define evk ev' !evdref; let (evk',_) = destEvar ev' in + (* spiwack: hacking session to mark the old [evk] as having been "cleared" *) + let evi = Evd.find !evdref evk in + let extra = evi.evar_extra in + let extra' = cleared.set true extra in + let evi' = { evi with evar_extra = extra' } in + evdref := Evd.add !evdref evk evi' ; + (* spiwack: /hacking session *) mkEvar(evk', Array.of_list nargs) end diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index 205ca8bd64..39f8dd05ac 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -193,6 +193,10 @@ type clear_dependency_error = exception ClearDependencyError of identifier * clear_dependency_error +(* spiwack: marks an evar that has been "defined" by clear. + used by [Goal] and (indirectly) [Proofview] to handle the clear tactic gracefully*) +val cleared : bool Store.Field.t + val clear_hyps_in_evi : evar_map ref -> named_context_val -> types -> identifier list -> named_context_val * types diff --git a/pretyping/evd.ml b/pretyping/evd.ml index a9b42f052b..5b4a3f214d 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -51,7 +51,7 @@ type evar_info = { evar_body : evar_body; evar_filter : bool list; evar_source : hole_kind located; - evar_extra : Dyn.t option} + evar_extra : Store.t } let make_evar hyps ccl = { evar_concl = ccl; @@ -59,7 +59,7 @@ let make_evar hyps ccl = { evar_body = Evar_empty; evar_filter = List.map (fun _ -> true) (named_context_of_val hyps); evar_source = (dummy_loc,InternalHole); - evar_extra = None + evar_extra = Store.empty } let evar_concl evi = evi.evar_concl @@ -93,26 +93,31 @@ module ExistentialSet = Intset (* This exception is raised by *.existential_value *) exception NotInstantiatedEvar + module EvarInfoMap = struct - type t = evar_info ExistentialMap.t + type t = evar_info ExistentialMap.t - let empty = ExistentialMap.empty + let empty = ExistentialMap.empty + let is_empty = ExistentialMap.is_empty let to_list evc = (* Workaround for change in Map.fold behavior *) + (* spiwack: seems to arrange the items in decreasing order. + Which would also be the behaviour of a naive [fold]. + I don't understand above comment. *) let l = ref [] in ExistentialMap.iter (fun evk x -> l := (evk,x)::!l) evc; !l let dom evc = ExistentialMap.fold (fun evk _ acc -> evk::acc) evc [] let find evc k = ExistentialMap.find k evc - let remove evc k = ExistentialMap.remove k evc + let remove evc k = ExistentialMap.remove k evc let mem evc k = ExistentialMap.mem k evc let fold = ExistentialMap.fold let exists evc f = ExistentialMap.fold (fun k v b -> b || f k v) evc false let add evd evk newinfo = ExistentialMap.add evk newinfo evd - let equal = ExistentialMap.equal + let map = ExistentialMap.map let define evd evk body = let oldinfo = @@ -182,6 +187,14 @@ module EvarInfoMap = struct try Some (existential_value sigma ev) with NotInstantiatedEvar -> None + (* Combinators on undefined evars. *) + let fold_undefined f = ExistentialMap.fold begin fun ev evi acc -> + match evar_body evi with + | Evar_empty -> f ev evi acc + | _ -> acc + end + + let undefined evm = fold_undefined ExistentialMap.add evm empty end (*******************************************************************) @@ -336,7 +349,23 @@ module EvarMap = struct (EvarInfoMap.find sigma2 k).evar_body <> Evar_empty) || not (UniverseMap.equal (=) sm1 sm2)) - let merge e e' = fold (fun n v sigma -> add sigma n v) e' e + (* spiwack: used to workaround a bug in clenv: evar_merge + could merge an "old" version of an evar map into + a more up to date and erase evar definitions (in the case + of [constructor_tac] it actually erased a goal in some cases). + This is due to the fact that [open_constr] carry around their own + sigma which can be outdated by other operations. *) + let add_if_more_recent evd evk newinfo = + if newinfo.evar_body = Evar_empty && mem evd evk then + evd + else + add evd evk newinfo + + let merge e e' = fold (fun n v sigma -> add_if_more_recent sigma n v) e' e + + (* combinators on undefined values *) + let undefined (sigma,sm) = (EvarInfoMap.undefined sigma,sm) + let fold_undefined f (sigma,_) = EvarInfoMap.fold_undefined f sigma end @@ -441,7 +470,6 @@ let progress_evar_map d1 d2 = (* spiwack: tentative. It might very well not be the semantics we want for merging evar_map *) let merge d1 d2 = { -(* d1 with evars = EvarMap.merge d1.evars d2.evars*) evars = EvarMap.merge d1.evars d2.evars ; conv_pbs = List.rev_append d1.conv_pbs d2.conv_pbs ; last_mods = ExistentialSet.union d1.last_mods d2.last_mods ; @@ -488,7 +516,7 @@ let subst_evar_defs_light sub evd = assert (evd.conv_pbs = []); { evd with metas = Metamap.map (map_clb (subst_mps sub)) evd.metas; - evars = ExistentialMap.map (subst_evar_info sub) (fst evd.evars), snd evd.evars + evars = EvarInfoMap.map (subst_evar_info sub) (fst evd.evars), (snd evd.evars) } let subst_evar_map = subst_evar_defs_light @@ -536,7 +564,7 @@ let evar_declare hyps evk ty ?(src=(dummy_loc,InternalHole)) ?filter evd = evar_body = Evar_empty; evar_filter = filter; evar_source = src; - evar_extra = None} } + evar_extra = Store.empty } } let is_defined_evar evd (evk,_) = EvarMap.is_defined evd.evars evk @@ -546,12 +574,10 @@ let is_undefined_evar evd c = match kind_of_term c with | _ -> false let undefined_evars evd = - let evars = - EvarMap.fold (fun evk evi sigma -> if evi.evar_body = Evar_empty then - EvarMap.add sigma evk evi else sigma) - evd.evars EvarMap.empty - in - { evd with evars = evars } + let evars = EvarMap.undefined evd.evars in + { evd with evars = evars } + +let fold_undefined f evd = EvarMap.fold_undefined f evd.evars (* extracts conversion problems that satisfy predicate p *) (* Note: conv_pbs not satisying p are stored back in reverse order *) @@ -694,7 +720,6 @@ let meta_with_name evd id = strbrk "\" occurs more than once in clause.") -(* spiwack: we should try and replace this List.fold_left by a Metamap.fold. *) let meta_merge evd1 evd2 = {evd2 with metas = List.fold_left (fun m (n,v) -> Metamap.add n v m) diff --git a/pretyping/evd.mli b/pretyping/evd.mli index b82e6d998d..f895ead42c 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -123,7 +123,7 @@ type evar_info = { evar_body : evar_body; evar_filter : bool list; evar_source : hole_kind located; - evar_extra : Dyn.t option} + evar_extra : Store.t } val eq_evar_info : evar_info -> evar_info -> bool @@ -185,6 +185,15 @@ val evars_reset_evd : evar_map -> evar_map -> evar_map for moving to evarutils *) val is_undefined_evar : evar_map -> constr -> bool val undefined_evars : evar_map -> evar_map +(* [fold_undefined f m] iterates ("folds") function [f] over the undefined + evars (that is, whose value is [Evar_empty]) of map [m]. + Making it effectively equivalent to {!Evd.fold} applies to + [f] and [undefined_evars m] *) +(* spiwack: at the moment, [fold_undefined] is defined rather naively. + But we can hope to enable some optimisation in the future, as + an evar_map contains typically few undefined evars compared to all + its evars. *) +val fold_undefined : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a val evar_declare : named_context_val -> evar -> types -> ?src:loc * hole_kind -> ?filter:bool list -> evar_map -> evar_map diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index cea33c1e98..6aa00c5f25 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -21,7 +21,6 @@ Typeclasses Classops Coercion Unification -Clenv Detyping Indrec Cases diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 4ec5cf1f17..88d4a4d6b3 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -355,18 +355,15 @@ let is_implicit_arg k = calls (e.g. when doing apply in an External hint in typeclass_instances). Would be solved by having real evars-as-goals. *) -let ((bool_in : bool -> Dyn.t), - (bool_out : Dyn.t -> bool)) = Dyn.create "bool" - -let bool_false = bool_in false +let resolvable = Store.field () +open Store.Field let is_resolvable evi = - match evi.evar_extra with - Some t -> if Dyn.tag t = "bool" then bool_out t else true - | None -> true + Option.default true (resolvable.get evi.evar_extra) let mark_unresolvable evi = - { evi with evar_extra = Some bool_false } + let t = resolvable.set false evi.evar_extra in + { evi with evar_extra = t } let mark_unresolvables sigma = Evd.fold (fun ev evi evs -> @@ -374,7 +371,7 @@ let mark_unresolvables sigma = sigma Evd.empty let has_typeclasses evd = - Evd.fold (fun ev evi has -> has || + Evd.fold_undefined (fun ev evi has -> has || (evi.evar_body = Evar_empty && is_class_evar evd evi && is_resolvable evi)) evd false diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index 997b28c105..e53be5c0bf 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -77,10 +77,6 @@ val is_implicit_arg : hole_kind -> bool val instance_constructor : typeclass -> constr list -> constr * types -(* Use evar_extra for marking resolvable evars. *) -val bool_in : bool -> Dyn.t -val bool_out : Dyn.t -> bool - val is_resolvable : evar_info -> bool val mark_unresolvable : evar_info -> evar_info val mark_unresolvables : evar_map -> evar_map diff --git a/proofs/clenv.ml b/proofs/clenv.ml new file mode 100644 index 0000000000..35db5e6ed1 --- /dev/null +++ b/proofs/clenv.ml @@ -0,0 +1,488 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* clrec t + | Prod (na,t,u) -> + let mv = new_meta () in + let dep = dependent (mkRel 1) u in + let na' = if dep then na else Anonymous in + let e' = meta_declare mv t ~name:na' cl.evd in + let concl = if dep then subst1 (mkMeta mv) u else u in + let def = applist (cl.templval.rebus,[mkMeta mv]) in + { templval = mk_freelisted def; + templtyp = mk_freelisted concl; + evd = e'; + env = cl.env } + | _ -> raise NotExtensibleClause + in clrec typ + +(* Instantiate the first [bound] products of [t] with metas (all products if + [bound] is [None]; unfold local defs *) + +let clenv_environments evd bound t = + let rec clrec (e,metas) n t = + match n, kind_of_term t with + | (Some 0, _) -> (e, List.rev metas, t) + | (n, Cast (t,_,_)) -> clrec (e,metas) n t + | (n, Prod (na,t1,t2)) -> + let mv = new_meta () in + let dep = dependent (mkRel 1) t2 in + let na' = if dep then na else Anonymous in + let e' = meta_declare mv t1 ~name:na' e in + clrec (e', (mkMeta mv)::metas) (Option.map ((+) (-1)) n) + (if dep then (subst1 (mkMeta mv) t2) else t2) + | (n, LetIn (na,b,_,t)) -> clrec (e,metas) n (subst1 b t) + | (n, _) -> (e, List.rev metas, t) + in + clrec (evd,[]) bound t + +(* Instantiate the first [bound] products of [t] with evars (all products if + [bound] is [None]; unfold local defs *) + +let clenv_environments_evars env evd bound t = + let rec clrec (e,ts) n t = + match n, kind_of_term t with + | (Some 0, _) -> (e, List.rev ts, t) + | (n, Cast (t,_,_)) -> clrec (e,ts) n t + | (n, Prod (na,t1,t2)) -> + let e',constr = Evarutil.new_evar e env t1 in + let dep = dependent (mkRel 1) t2 in + clrec (e', constr::ts) (Option.map ((+) (-1)) n) + (if dep then (subst1 constr t2) else t2) + | (n, LetIn (na,b,_,t)) -> clrec (e,ts) n (subst1 b t) + | (n, _) -> (e, List.rev ts, t) + in + clrec (evd,[]) bound t + +let clenv_conv_leq env sigma t c bound = + let ty = Retyping.get_type_of env sigma c in + let evd = Evd.create_goal_evar_defs sigma in + let evars,args,_ = clenv_environments_evars env evd (Some bound) ty in + let evars = Evarconv.the_conv_x_leq env t (applist (c,args)) evars in + let evars = Evarconv.consider_remaining_unif_problems env evars in + let args = List.map (whd_evar evars) args in + check_evars env sigma evars (applist (c,args)); + args + +let mk_clenv_from_env environ sigma n (c,cty) = + let evd = create_goal_evar_defs sigma in + let (evd,args,concl) = clenv_environments evd n cty in + { templval = mk_freelisted (match args with [] -> c | _ -> applist (c,args)); + templtyp = mk_freelisted concl; + evd = evd; + env = environ } + +let mk_clenv_from_n gls n (c,cty) = + mk_clenv_from_env (pf_env gls) gls.sigma n (c, cty) + +let mk_clenv_from gls = mk_clenv_from_n gls None + +let mk_clenv_rename_from_n gls n (c,t) = + mk_clenv_from_n gls n (c,rename_bound_vars_as_displayed [] t) + +let mk_clenv_type_of gls t = mk_clenv_from gls (t,pf_type_of gls t) + +(******************************************************************) + +(* [mentions clenv mv0 mv1] is true if mv1 is defined and mentions + * mv0, or if one of the free vars on mv1's freelist mentions + * mv0 *) + +let mentions clenv mv0 = + let rec menrec mv1 = + mv0 = mv1 || + let mlist = + try match meta_opt_fvalue clenv.evd mv1 with + | Some (b,_) -> b.freemetas + | None -> Metaset.empty + with Not_found -> Metaset.empty in + meta_exists menrec mlist + in menrec + +let error_incompatible_inst clenv mv = + let na = meta_name clenv.evd mv in + match na with + Name id -> + errorlabstrm "clenv_assign" + (str "An incompatible instantiation has already been found for " ++ + pr_id id) + | _ -> + anomaly "clenv_assign: non dependent metavar already assigned" + +(* TODO: replace by clenv_unify (mkMeta mv) rhs ? *) +let clenv_assign mv rhs clenv = + let rhs_fls = mk_freelisted rhs in + if meta_exists (mentions clenv mv) rhs_fls.freemetas then + error "clenv_assign: circularity in unification"; + try + if meta_defined clenv.evd mv then + if not (eq_constr (fst (meta_fvalue clenv.evd mv)).rebus rhs) then + error_incompatible_inst clenv mv + else + clenv + else + let st = (ConvUpToEta 0,TypeNotProcessed) in + {clenv with evd = meta_assign mv (rhs_fls.rebus,st) clenv.evd} + with Not_found -> + error "clenv_assign: undefined meta" + + + +(* [clenv_dependent hyps_only clenv] + * returns a list of the metavars which appear in the template of clenv, + * and which are dependent, This is computed by taking the metavars in cval, + * in right-to-left order, and collecting the metavars which appear + * in their types, and adding in all the metavars appearing in the + * type of clenv. + * If [hyps_only] then metavariables occurring in the type are _excluded_ *) + +(* [clenv_metavars clenv mv] + * returns a list of the metavars which appear in the type of + * the metavar mv. The list is unordered. *) + +let clenv_metavars evd mv = + (mk_freelisted (meta_instance evd (meta_ftype evd mv))).freemetas + +let dependent_metas clenv mvs conclmetas = + List.fold_right + (fun mv deps -> + Metaset.union deps (clenv_metavars clenv.evd mv)) + mvs conclmetas + +let duplicated_metas c = + let rec collrec (one,more as acc) c = + match kind_of_term c with + | Meta mv -> if List.mem mv one then (one,mv::more) else (mv::one,more) + | _ -> fold_constr collrec acc c + in + snd (collrec ([],[]) c) + +let clenv_dependent hyps_only clenv = + let mvs = undefined_metas clenv.evd in + let ctyp_mvs = (mk_freelisted (clenv_type clenv)).freemetas in + let deps = dependent_metas clenv mvs ctyp_mvs in + let nonlinear = duplicated_metas (clenv_value clenv) in + (* Make the assumption that duplicated metas have internal dependencies *) + List.filter + (fun mv -> if Metaset.mem mv deps + then not (hyps_only && Metaset.mem mv ctyp_mvs) + else List.mem mv nonlinear) + mvs + +let clenv_missing ce = clenv_dependent true ce + +(******************************************************************) + +let clenv_unify allow_K ?(flags=default_unify_flags) cv_pb t1 t2 clenv = + { clenv with + evd = w_unify allow_K ~flags:flags clenv.env cv_pb t1 t2 clenv.evd } + +let clenv_unify_meta_types ?(flags=default_unify_flags) clenv = + { clenv with evd = w_unify_meta_types ~flags:flags clenv.env clenv.evd } + +let clenv_unique_resolver allow_K ?(flags=default_unify_flags) clenv gl = + let concl = Goal.V82.concl clenv.evd (sig_it gl) in + if isMeta (fst (whd_stack clenv.evd clenv.templtyp.rebus)) then + clenv_unify allow_K CUMUL ~flags:flags (clenv_type clenv) concl + (clenv_unify_meta_types ~flags:flags clenv) + else + clenv_unify allow_K CUMUL ~flags:flags + (meta_reducible_instance clenv.evd clenv.templtyp) concl clenv + +(* [clenv_pose_metas_as_evars clenv dep_mvs] + * For each dependent evar in the clause-env which does not have a value, + * pose a value for it by constructing a fresh evar. We do this in + * left-to-right order, so that every evar's type is always closed w.r.t. + * metas. + + * Node added 14/4/08 [HH]: before this date, evars were collected in + clenv_dependent by collect_metas in the fold_constr order which is + (almost) the left-to-right order of dependencies in term. However, + due to K-redexes, collect_metas was sometimes missing some metas. + The call to collect_metas has been replaced by a call to + undefined_metas, but then the order was the one of definition of + the metas (numbers in increasing order) which is _not_ the + dependency order when a clenv_fchain occurs (because clenv_fchain + plugs a term with a list of consecutive metas in place of a - a priori - + arbitrary metavariable belonging to another sequence of consecutive metas: + e.g., clenv_fchain may plug (H ?1 ?2) at the position ?6 of + (nat_ind ?3 ?4 ?5 ?6), leading to a dependency order 3<4<5<1<2). + To ensure the dependency order, we check that the type of each meta + to pose is already meta-free, otherwise we postpone the transformation, + hoping that no cycle may happen. + + Another approach could have been to use decimal numbers for metas so that + in the example above, (H ?1 ?2) would have been renumbered (H ?6.1 ?6.2) + then making the numeric order match the dependency order. +*) + +let clenv_pose_metas_as_evars clenv dep_mvs = + let rec fold clenv = function + | [] -> clenv + | mv::mvs -> + let ty = clenv_meta_type clenv mv in + (* Postpone the evar-ization if dependent on another meta *) + (* This assumes no cycle in the dependencies - is it correct ? *) + if occur_meta ty then fold clenv (mvs@[mv]) + else + let (evd,evar) = + new_evar clenv.evd (cl_env clenv) ~src:(dummy_loc,GoalEvar) ty in + let clenv = clenv_assign mv evar {clenv with evd=evd} in + fold clenv mvs in + fold clenv dep_mvs + +let evar_clenv_unique_resolver = clenv_unique_resolver + +(******************************************************************) + +let connect_clenv gls clenv = + let evd = Evd.fold begin fun ev evi acc -> + if evi.evar_body = Evar_empty then + acc + else + Evd.add acc ev evi + end + clenv.evd gls.sigma + in + let evd = evars_reset_evd evd clenv.evd in + { clenv with + evd = evd ; + env = Goal.V82.env evd (sig_it gls) } + +(* [clenv_fchain mv clenv clenv'] + * + * Resolves the value of "mv" (which must be undefined) in clenv to be + * the template of clenv' be the value "c", applied to "n" fresh + * metavars, whose types are chosen by destructing "clf", which should + * be a clausale forme generated from the type of "c". The process of + * resolution can cause unification of already-existing metavars, and + * of the fresh ones which get created. This operation is a composite + * of operations which pose new metavars, perform unification on + * terms, and make bindings. + + Otherwise said, from + + [clenv] = [env;sigma;metas |- c:T] + [clenv'] = [env';sigma';metas' |- d:U] + [mv] = [mi] of type [Ti] in [metas] + + then, if the unification of [Ti] and [U] produces map [rho], the + chaining is [env';sigma';rho'(metas),rho(metas') |- c:rho'(T)] for + [rho'] being [rho;mi:=d]. + + In particular, it assumes that [env'] and [sigma'] extend [env] and [sigma]. +*) +let clenv_fchain ?(allow_K=true) ?(flags=default_unify_flags) mv clenv nextclenv = + (* Add the metavars of [nextclenv] to [clenv], with their name-environment *) + let clenv' = + { templval = clenv.templval; + templtyp = clenv.templtyp; + evd = + evar_merge (meta_merge clenv.evd nextclenv.evd) clenv.evd; + env = nextclenv.env } in + (* unify the type of the template of [nextclenv] with the type of [mv] *) + let clenv'' = + clenv_unify allow_K ~flags:flags CUMUL + (clenv_term clenv' nextclenv.templtyp) + (clenv_meta_type clenv' mv) + clenv' in + (* assign the metavar *) + let clenv''' = + clenv_assign mv (clenv_term clenv' nextclenv.templval) clenv'' + in + clenv''' + +(***************************************************************) +(* Bindings *) + +type arg_bindings = constr explicit_bindings + +(* [clenv_independent clenv] + * returns a list of metavariables which appear in the term cval, + * and which are not dependent. That is, they do not appear in + * the types of other metavars which are in cval, nor in the type + * of cval, ctyp. *) + +let clenv_independent clenv = + let mvs = collect_metas (clenv_value clenv) in + let ctyp_mvs = (mk_freelisted (clenv_type clenv)).freemetas in + let deps = dependent_metas clenv mvs ctyp_mvs in + List.filter (fun mv -> not (Metaset.mem mv deps)) mvs + +let check_bindings bl = + match list_duplicates (List.map pi2 bl) with + | NamedHyp s :: _ -> + errorlabstrm "" + (str "The variable " ++ pr_id s ++ + str " occurs more than once in binding list."); + | AnonHyp n :: _ -> + errorlabstrm "" + (str "The position " ++ int n ++ + str " occurs more than once in binding list.") + | [] -> () + +let meta_of_binder clause loc mvs = function + | NamedHyp s -> meta_with_name clause.evd s + | AnonHyp n -> + try List.nth mvs (n-1) + with (Failure _|Invalid_argument _) -> + errorlabstrm "" (str "No such binder.") + +let error_already_defined b = + match b with + | NamedHyp id -> + errorlabstrm "" + (str "Binder name \"" ++ pr_id id ++ + str"\" already defined with incompatible value.") + | AnonHyp n -> + anomalylabstrm "" + (str "Position " ++ int n ++ str" already defined.") + +let clenv_unify_binding_type clenv c t u = + if isMeta (fst (whd_stack clenv.evd u)) then + (* Not enough information to know if some subtyping is needed *) + CoerceToType, clenv, c + else + (* Enough information so as to try a coercion now *) + try + let evd,c = w_coerce_to_type (cl_env clenv) clenv.evd c t u in + TypeProcessed, { clenv with evd = evd }, c + with + | PretypeError (_,NotClean _) as e -> raise e + | e when precatchable_exception e -> + TypeNotProcessed, clenv, c + +let clenv_assign_binding clenv k c = + let k_typ = clenv_hnf_constr clenv (clenv_meta_type clenv k) in + let c_typ = nf_betaiota clenv.evd (clenv_get_type_of clenv c) in + let status,clenv',c = clenv_unify_binding_type clenv c c_typ k_typ in + { clenv' with evd = meta_assign k (c,(UserGiven,status)) clenv'.evd } + +let clenv_match_args bl clenv = + if bl = [] then + clenv + else + let mvs = clenv_independent clenv in + check_bindings bl; + List.fold_left + (fun clenv (loc,b,c) -> + let k = meta_of_binder clenv loc mvs b in + if meta_defined clenv.evd k then + if eq_constr (fst (meta_fvalue clenv.evd k)).rebus c then clenv + else error_already_defined b + else + clenv_assign_binding clenv k c) + clenv bl + +let clenv_constrain_last_binding c clenv = + let all_mvs = collect_metas clenv.templval.rebus in + let k = + try list_last all_mvs + with Failure _ -> anomaly "clenv_constrain_with_bindings" in + clenv_assign_binding clenv k c + +let clenv_constrain_dep_args hyps_only bl clenv = + if bl = [] then + clenv + else + let occlist = clenv_dependent hyps_only clenv in + if List.length occlist = List.length bl then + List.fold_left2 clenv_assign_binding clenv occlist bl + else + errorlabstrm "" + (strbrk "Not the right number of missing arguments (expected " ++ + int (List.length occlist) ++ str ").") + +(****************************************************************) +(* Clausal environment for an application *) + +let make_clenv_binding_gen hyps_only n gls (c,t) = function + | ImplicitBindings largs -> + let clause = mk_clenv_from_n gls n (c,t) in + clenv_constrain_dep_args hyps_only largs clause + | ExplicitBindings lbind -> + let clause = mk_clenv_rename_from_n gls n (c,t) in + clenv_match_args lbind clause + | NoBindings -> + mk_clenv_from_n gls n (c,t) + +let make_clenv_binding_apply gls n = make_clenv_binding_gen true n gls +let make_clenv_binding = make_clenv_binding_gen false None + +(****************************************************************) +(* Pretty-print *) + +let pr_clenv clenv = + h 0 + (str"TEMPL: " ++ print_constr clenv.templval.rebus ++ + str" : " ++ print_constr clenv.templtyp.rebus ++ fnl () ++ + pr_evar_map clenv.evd) diff --git a/proofs/clenv.mli b/proofs/clenv.mli new file mode 100644 index 0000000000..2533fc5379 --- /dev/null +++ b/proofs/clenv.mli @@ -0,0 +1,143 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* clausenv -> clausenv + +(* subject of clenv (instantiated) *) +val clenv_value : clausenv -> constr +(* type of clenv (instantiated) *) +val clenv_type : clausenv -> types +(* substitute resolved metas *) +val clenv_nf_meta : clausenv -> constr -> constr +(* type of a meta in clenv context *) +val clenv_meta_type : clausenv -> metavariable -> types + +val mk_clenv_from : Goal.goal sigma -> constr * types -> clausenv +val mk_clenv_from_n : + Goal.goal sigma -> int option -> constr * types -> clausenv +val mk_clenv_type_of : Goal.goal sigma -> constr -> clausenv +val mk_clenv_from_env : env -> evar_map -> int option -> constr * types -> clausenv + +(***************************************************************) +(* linking of clenvs *) + +val connect_clenv : Goal.goal sigma -> clausenv -> clausenv +val clenv_fchain : + ?allow_K:bool -> ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv + +(***************************************************************) +(* Unification with clenvs *) + +(* Unifies two terms in a clenv. The boolean is [allow_K] (see [Unification]) *) +val clenv_unify : + bool -> ?flags:unify_flags -> conv_pb -> constr -> constr -> clausenv -> clausenv + +(* unifies the concl of the goal with the type of the clenv *) +val clenv_unique_resolver : + bool -> ?flags:unify_flags -> clausenv -> Goal.goal sigma -> clausenv + +(* same as above ([allow_K=false]) but replaces remaining metas + with fresh evars if [evars_flag] is [true] *) +val evar_clenv_unique_resolver : + bool -> ?flags:unify_flags -> clausenv -> Goal.goal sigma -> clausenv + +val clenv_dependent : bool -> clausenv -> metavariable list + +val clenv_pose_metas_as_evars : clausenv -> metavariable list -> clausenv + +(***************************************************************) +(* Bindings *) + +type arg_bindings = constr explicit_bindings + +(* bindings where the key is the position in the template of the + clenv (dependent or not). Positions can be negative meaning to + start from the rightmost argument of the template. *) +val clenv_independent : clausenv -> metavariable list +val clenv_missing : clausenv -> metavariable list + +val clenv_constrain_last_binding : constr -> clausenv -> clausenv + +(* defines metas corresponding to the name of the bindings *) +val clenv_match_args : arg_bindings -> clausenv -> clausenv + +val clenv_unify_meta_types : ?flags:unify_flags -> clausenv -> clausenv + +(* start with a clenv to refine with a given term with bindings *) + +(* the arity of the lemma is fixed *) +(* the optional int tells how many prods of the lemma have to be used *) +(* use all of them if None *) +val make_clenv_binding_apply : + Goal.goal sigma -> int option -> constr * constr -> constr bindings -> + clausenv +val make_clenv_binding : + Goal.goal sigma -> constr * constr -> constr bindings -> clausenv + +(* [clenv_environments sigma n t] returns [sigma',lmeta,ccl] where + [lmetas] is a list of metas to be applied to a proof of [t] so that + it produces the unification pattern [ccl]; [sigma'] is [sigma] + extended with [lmetas]; if [n] is defined, it limits the size of + the list even if [ccl] is still a product; otherwise, it stops when + [ccl] is not a product; example: if [t] is [forall x y, x=y -> y=x] + and [n] is [None], then [lmetas] is [Meta n1;Meta n2;Meta n3] and + [ccl] is [Meta n1=Meta n2]; if [n] is [Some 1], [lmetas] is [Meta n1] + and [ccl] is [forall y, Meta n1=y -> y=Meta n1] *) +val clenv_environments : + evar_map -> int option -> types -> evar_map * constr list * types + +(* [clenv_environments_evars env sigma n t] does the same but returns + a list of Evar's defined in [env] and extends [sigma] accordingly *) +val clenv_environments_evars : + env -> evar_map -> int option -> types -> evar_map * constr list * types + +(* [clenv_conv_leq env sigma t c n] looks for c1...cn s.t. [t <= c c1...cn] *) +val clenv_conv_leq : + env -> evar_map -> types -> constr -> int -> constr list + +(* if the clause is a product, add an extra meta for this product *) +exception NotExtensibleClause +val clenv_push_prod : clausenv -> clausenv + +(***************************************************************) +(* Pretty-print *) +val pr_clenv : clausenv -> Pp.std_ppcmds + diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 9bc818e861..f977768bd6 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -20,7 +20,6 @@ open Evd open Evarutil open Proof_type open Refiner -open Proof_trees open Logic open Reduction open Reductionops diff --git a/proofs/decl_expr.mli b/proofs/decl_expr.mli deleted file mode 100644 index 20a95dabff..0000000000 --- a/proofs/decl_expr.mli +++ /dev/null @@ -1,105 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Mode_none - -let check_not_proof_mode str = - if get_current_mode () = Mode_proof then - error str - -type split_tree= - Skip_patt of Idset.t * split_tree - | Split_patt of Idset.t * inductive * - (bool array * (Idset.t * split_tree) option) array - | Close_patt of split_tree - | End_patt of (identifier * (int * int)) - -type elim_kind = - EK_dep of split_tree - | EK_nodep - | EK_unknown - -type recpath = int option*Declarations.wf_paths - -type per_info = - {per_casee:constr; - per_ctype:types; - per_ind:inductive; - per_pred:constr; - per_args:constr list; - per_params:constr list; - per_nparams:int; - per_wf:recpath} - -type stack_info = - Per of Decl_expr.elim_type * per_info * elim_kind * identifier list - | Suppose_case - | Claim - | Focus_claim - -type pm_info = - { pm_stack : stack_info list} - -let pm_in,pm_out = Dyn.create "pm_info" - -let get_info gl= - match gl.evar_extra with - None -> invalid_arg "get_info" - | Some extra -> - try pm_out extra with _ -> invalid_arg "get_info" - -let get_stack pts = - let info = get_info (sig_it (Refiner.nth_goal_of_pftreestate 1 pts)) in - info.pm_stack - -let get_top_stack pts = - let info = get_info (sig_it (Refiner.top_goal_of_pftreestate pts)) in - info.pm_stack - -let get_end_command pts = - match mode_of_pftreestate pts with - Mode_proof -> - Some - begin - match get_top_stack pts with - [] -> "\"end proof\"" - | Claim::_ -> "\"end claim\"" - | Focus_claim::_-> "\"end focus\"" - | (Suppose_case :: Per (et,_,_,_) :: _ - | Per (et,_,_,_) :: _ ) -> - begin - match et with - Decl_expr.ET_Case_analysis -> - "\"end cases\" or start a new case" - | Decl_expr.ET_Induction -> - "\"end induction\" or start a new case" - end - | _ -> anomaly "lonely suppose" - end - | Mode_tactic -> - begin - try - ignore - (Refiner.up_until_matching_rule Proof_trees.is_proof_instr pts); - Some "\"return\"" - with Not_found -> None - end - | Mode_none -> - error "no proof in progress" - -let get_last env = - try - let (id,_,_) = List.hd (Environ.named_context env) in id - with Invalid_argument _ -> error "no previous statement to use" - diff --git a/proofs/decl_mode.mli b/proofs/decl_mode.mli deleted file mode 100644 index 734dc04421..0000000000 --- a/proofs/decl_mode.mli +++ /dev/null @@ -1,74 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit -val clear_daimon_flag : unit -> unit -val get_daimon_flag : unit -> bool - -type command_mode = - Mode_tactic - | Mode_proof - | Mode_none - -val mode_of_pftreestate : pftreestate -> command_mode - -val get_current_mode : unit -> command_mode - -val check_not_proof_mode : string -> unit - -type split_tree= - Skip_patt of Idset.t * split_tree - | Split_patt of Idset.t * inductive * - (bool array * (Idset.t * split_tree) option) array - | Close_patt of split_tree - | End_patt of (identifier * (int * int)) - -type elim_kind = - EK_dep of split_tree - | EK_nodep - | EK_unknown - -type recpath = int option*Declarations.wf_paths - -type per_info = - {per_casee:constr; - per_ctype:types; - per_ind:inductive; - per_pred:constr; - per_args:constr list; - per_params:constr list; - per_nparams:int; - per_wf:recpath} - -type stack_info = - Per of Decl_expr.elim_type * per_info * elim_kind * Names.identifier list - | Suppose_case - | Claim - | Focus_claim - -type pm_info = - {pm_stack : stack_info list } - -val pm_in : pm_info -> Dyn.t - -val get_info : Proof_type.goal -> pm_info - -val get_end_command : pftreestate -> string option - -val get_stack : pftreestate -> stack_info list - -val get_top_stack : pftreestate -> stack_info list - -val get_last: Environ.env -> identifier diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index e4fab3f2f8..6dfbbdc121 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -14,7 +14,6 @@ open Term open Evd open Evarutil open Sign -open Proof_trees open Refiner (******************************************) @@ -55,19 +54,10 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = (* vernac command Existential *) -let instantiate_pf_com n com pfts = - let gls = top_goal_of_pftreestate pfts in - let sigma = gls.sigma in - let (evk,evi) = - let evl = Evarutil.non_instantiated sigma in - if (n <= 0) then - error "incorrect existential variable index" - else if List.length evl < n then - error "not so many uninstantiated existential variables" - else - List.nth evl (n-1) - in +(* Main component of vernac command Existential *) +let instantiate_pf_com evk com sigma = + let evi = Evd.find sigma evk in let env = Evd.evar_env evi in let rawc = Constrintern.intern_constr sigma env com in let sigma' = w_refine (evk,evi) (([],[]),rawc) sigma in - change_constraints_pftreestate sigma' pfts + sigma' diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli index 0bd6168095..28c79d11e9 100644 --- a/proofs/evar_refiner.mli +++ b/proofs/evar_refiner.mli @@ -24,6 +24,6 @@ val w_refine : evar * evar_info -> (var_map * unbound_ltac_var_map) * rawconstr -> evar_map -> evar_map val instantiate_pf_com : - int -> Topconstr.constr_expr -> pftreestate -> pftreestate + Evd.evar -> Topconstr.constr_expr -> Evd.evar_map -> Evd.evar_map (* the instantiate tactic was moved to [tactics/evar_tactics.ml] *) diff --git a/proofs/goal.ml b/proofs/goal.ml new file mode 100644 index 0000000000..a9202318df --- /dev/null +++ b/proofs/goal.ml @@ -0,0 +1,572 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* c + | _ -> Util.anomaly "Some goal is marked as 'cleared' but is uninstantiated" + in + let (e,_) = Term.destEvar v in + let g' = { g with content = e } in + advance sigma g' + else + match evi.Evd.evar_body with + | Evd.Evar_defined _ -> None + | _ -> Some g + +(*** Goal tactics ***) + + +(* Goal tactics are [subgoal sensitive]-s *) +type subgoals = { subgoals: goal list } + +(* type of the base elements of the goal API.*) +(* it has an extra evar_info with respect to what would be expected, + it is supposed to be the evar_info of the goal in the evar_map. + The idea is that it is computed by the [run] function as an + optimisation, since it will generaly not change during the + evaluation. *) +type 'a sensitive = + Environ.env -> Evd.evar_map ref -> goal -> Evd.evar_info -> 'a + +(* evaluates a goal sensitive value in a given goal (knowing the current evar_map). *) +(* the evar_info corresponding to the goal is computed at once + as an optimisation (it shouldn't change during the evaluation). *) +let eval t env defs gl = + let info = content defs gl in + let env = Environ.reset_with_named_context (Evd.evar_hyps info) env in + let rdefs = ref defs in + let r = t env rdefs gl info in + ( r , !rdefs ) + +(* monadic bind on sensitive expressions *) +let bind e f env rdefs goal info = + f (e env rdefs goal info) env rdefs goal info + +(* monadic return on sensitive expressions *) +let return v _ _ _ _ = v + +(* interpretation of "open" constr *) +(* spiwack: it is a wrapper around [Constrintern.interp_open_constr]. + In an ideal world, this could/should be the other way round. + As of now, though, it seems at least quite useful to build tactics. *) +let interp_constr cexpr env rdefs _ _ = + let (defs,c) = Constrintern.interp_open_constr !rdefs env cexpr in + rdefs := defs ; + c + +(* Type of constr with holes used by refine. *) +(* The list of evars doesn't necessarily contain all the evars in the constr, + only those the constr has introduced. *) +(* The variables in [myevars] are supposed to be stored + in decreasing order. Breaking this invariant might cause + many things to go wrong. *) +type refinable = { + me: constr; + my_evars: Evd.evar list +} + +module Refinable = struct + type t = refinable + + type handle = Evd.evar list ref + + let make t env rdefs gl info = + let r = ref [] in + let me = t r env rdefs gl info in + { me = me; + my_evars = !r } + let make_with t env rdefs gl info = + let r = ref [] in + let (me,side) = t r env rdefs gl info in + { me = me ; my_evars = !r } , side + + let mkEvar handle env typ _ rdefs _ _ = + let ev = Evarutil.e_new_evar rdefs env typ in + let (e,_) = Term.destEvar ev in + handle := e::!handle; + ev + + (* [with_type c typ] constrains term [c] to have type [typ]. *) + let with_type t typ env rdefs _ _ = + (* spiwack: this function assumes that no evars can be created during + this sort of coercion. + If it is not the case it could produce bugs. We would need to add a handle + and add the new evars to it. *) + let my_type = Retyping.get_type_of env !rdefs t in + let j = Environ.make_judge t my_type in + let tycon = Evarutil.mk_tycon_type typ in + let (new_defs,j') = + Coercion.Default.inh_conv_coerce_to (Util.dummy_loc) env !rdefs j tycon + in + rdefs := new_defs; + j'.Environ.uj_val + + (* spiwack: it is not very fine grain since it solves all typeclasses holes, + not only those containing the current goal, or a given term. But it + seems to fit our needs so far. *) + let resolve_typeclasses ?onlyargs ?split ?(fail=false) () env rdefs _ _ = + rdefs:=Typeclasses.resolve_typeclasses ?onlyargs ?split ~fail env !rdefs; + () + + + + (* a pessimistic (i.e : there won't be many positive answers) filter + over evar_maps *) + let evar_map_filter f evm = + Evd.fold (fun ev evi r -> + if f ev evi then + Evd.add r ev evi + else + r + ) + evm + Evd.empty + + (* Union, sorted in decreasing order, of two lists of evars in decreasing order. *) + let rec fusion l1 l2 = match l1 , l2 with + | [] , _ -> l2 + | _ , [] -> l1 + | a::l1 , b::_ when a>b -> a::(fusion l1 l2) + | a::l1 , b::l2 when a=b -> a::(fusion l1 l2) + | _ , b::l2 -> b::(fusion l1 l2) + + (* [constr_of_raw] is a pretyping function. The [check_type] argument + asks whether the term should have the same type as the conclusion. + [resolve_classes] is a flag on pretyping functions which, if set to true, + calls the typeclass resolver. + The principal argument is a [rawconstr] which is then pretyped in the + context of a term, the remaining evars are registered to the handle. + It is the main component of the toplevel refine tactic.*) + (* spiwack: it is not entirely satisfactory to have this function here. Plus it is + a bit hackish. However it does not seem possible to move it out until + pretyping is defined as some proof procedure. *) + let constr_of_raw handle check_type resolve_classes rawc env rdefs gl info = + (* We need to keep trace of what [rdefs] was originally*) + let init_defs = !rdefs in + (* if [check_type] is true, then creates a type constraint for the + proof-to-be *) + let tycon = Pretyping.OfType (Option.init check_type (Evd.evar_concl info)) in + (* call to [understand_tcc_evars] returns a constr with undefined evars + these evars will be our new goals *) + let open_constr = + Pretyping.Default.understand_tcc_evars ~resolve_classes rdefs env tycon rawc + in + (* [!rdefs] contains the evar_map outputed by [understand_...] *) + let post_defs = !rdefs in + (* [delta_evars] holds the evars that have been introduced by this + refinement (but not immediatly solved) *) + (* spiwack: this is the hackish part, don't know how to do any better though. *) + let delta_evars = evar_map_filter (fun ev evi -> + evi.Evd.evar_body = Evd.Evar_empty && + not (Evd.mem init_defs ev) + ) + post_defs + in + (* [delta_evars] in the shape of a list of [evar]-s*) + let delta_list = List.map fst (Evd.to_list delta_evars) in + (* The variables in [myevars] are supposed to be stored + in decreasing order. Breaking this invariant might cause + many things to go wrong. *) + handle := fusion delta_list !handle ; + open_constr + +end + +(* [refine t] takes a refinable term and use it as a partial proof for current + goal. *) +let refine step env rdefs gl info = + (* subgoals to return *) + (* The evars in [my_evars] are stored in reverse order. + It is expectingly better however to display the goal + in increasing order. *) + rdefs := Evarconv.consider_remaining_unif_problems env !rdefs ; + let subgoals = List.map (descendent gl) (List.rev step.my_evars) in + (* creates the new [evar_map] by defining the evar of the current goal + as being [refine_step]. *) + let new_defs = Evd.define gl.content (step.me) !rdefs in + rdefs := new_defs; + (* Filtering the [subgoals] for uninstanciated (=unsolved) goals. *) + let subgoals = + Option.List.flatten (List.map (advance !rdefs) subgoals) + in + { subgoals = subgoals } + + +(*** Cleaning goals ***) + +let clear ids env rdefs gl info = + let hyps = Evd.evar_hyps info in + let concl = Evd.evar_concl info in + let (hyps,concl) = Evarutil.clear_hyps_in_evi rdefs hyps concl ids in + let cleared_env = Environ.reset_with_named_context hyps env in + let cleared_concl = Evarutil.e_new_evar rdefs cleared_env concl in + let (cleared_evar,_) = Term.destEvar cleared_concl in + let cleared_goal = descendent gl cleared_evar in + rdefs := Evd.define gl.content cleared_concl !rdefs; + { subgoals = [cleared_goal] } + +let wrap_apply_to_hyp_and_dependent_on sign id f g = + try Environ.apply_to_hyp_and_dependent_on sign id f g + with Environ.Hyp_not_found -> + Util.error "No such assumption" + +let check_typability env sigma c = + let _ = Typing.type_of env sigma c in () + +let recheck_typability (what,id) env sigma t = + try check_typability env sigma t + with _ -> + let s = match what with + | None -> "the conclusion" + | Some id -> "hypothesis "^(Names.string_of_id id) in + Util.error + ("The correctness of "^s^" relies on the body of "^(Names.string_of_id id)) + +let remove_hyp_body env sigma id = + let sign = + wrap_apply_to_hyp_and_dependent_on (Environ.named_context_val env) id + (fun (_,c,t) _ -> + match c with + | None -> Util.error ((Names.string_of_id id)^" is not a local definition") + | Some c ->(id,None,t)) + (fun (id',c,t as d) sign -> + ( + begin + let env = Environ.reset_with_named_context sign env in + match c with + | None -> recheck_typability (Some id',id) env sigma t + | Some b -> + let b' = mkCast (b,DEFAULTcast, t) in + recheck_typability (Some id',id) env sigma b' + end;d)) + in + Environ.reset_with_named_context sign env + + +let clear_body idents env rdefs gl info = + let info = content !rdefs gl in + let full_env = Environ.reset_with_named_context (Evd.evar_hyps info) env in + let aux env id = + let env' = remove_hyp_body env !rdefs id in + recheck_typability (None,id) env' !rdefs (Evd.evar_concl info); + env' + in + let new_env = + List.fold_left aux full_env idents + in + let concl = Evd.evar_concl info in + let (defs',new_constr) = Evarutil.new_evar !rdefs new_env concl in + let (new_evar,_) = destEvar new_constr in + let new_goal = descendent gl new_evar in + rdefs := Evd.define gl.content new_constr defs'; + { subgoals = [new_goal] } + + +(*** Sensitive primitives ***) + +(* [concl] is the conclusion of the current goal *) +let concl _ _ _ info = + Evd.evar_concl info + +(* [hyps] is the [named_context_val] representing the hypotheses + of the current goal *) +let hyps _ _ _ info = + Evd.evar_hyps info + +(* [env] is the current [Environ.env] containing both the + environment in which the proof is ran, and the goal hypotheses *) +let env env _ _ _ = env + +(* [defs] is the [Evd.evar_map] at the current evaluation point *) +let defs _ rdefs _ _ = + !rdefs + +(* Cf mli for more detailed comment. + [null], [plus], [here] and [here_list] use internal exception [UndefinedHere] + to communicate whether or not the value is defined in the particular context. *) +exception UndefinedHere +let null _ _ _ _ = raise UndefinedHere + +let plus s1 s2 env rdefs goal info = + try s1 env rdefs goal info + with UndefinedHere -> s2 env rdefs goal info + +(* Equality of two goals *) +let equal { content = e1 } { content = e2 } = e1 = e2 + +let here goal value _ _ goal' _ = + if equal goal goal' then + value + else + raise UndefinedHere + +(* arnaud: voir à la passer dans Util ? *) +let rec list_mem_with eq x = function + | y::_ when eq x y -> true + | _::l -> list_mem_with eq x l + | [] -> false + +let here_list goals value _ _ goal' _ = + if list_mem_with equal goal' goals then + value + else + raise UndefinedHere + + +(*** Conversion in goals ***) + +let convert_hyp check (id,b,bt as d) env rdefs gl info = + let sigma = !rdefs in + (* This function substitutes the new type and body definitions + in the appropriate variable when used with {!Environ.apply_hyps}. *) + let replace_function = + (fun _ (_,c,ct) _ -> + if check && not (Reductionops.is_conv env sigma bt ct) then + Util.error ("Incorrect change of the type of "^(Names.string_of_id id)); + if check && not (Option.Misc.compare (Reductionops.is_conv env sigma) b c) then + Util.error ("Incorrect change of the body of "^(Names.string_of_id id)); + d) + in + (* Modified named context. *) + let new_hyps = + Environ.apply_to_hyp (hyps env rdefs gl info) id replace_function + in + let new_env = Environ.reset_with_named_context new_hyps env in + let new_constr = + Evarutil.e_new_evar rdefs new_env (concl env rdefs gl info) + in + let (new_evar,_) = Term.destEvar new_constr in + let new_goal = descendent gl new_evar in + rdefs := Evd.define gl.content new_constr !rdefs; + { subgoals = [new_goal] } + +let convert_concl check cl' env rdefs gl info = + let sigma = !rdefs in + let cl = concl env rdefs gl info in + check_typability env sigma cl'; + if (not check) || Reductionops.is_conv_leq env sigma cl' cl then + let new_constr = + Evarutil.e_new_evar rdefs env cl' + in + let (new_evar,_) = Term.destEvar new_constr in + let new_goal = descendent gl new_evar in + rdefs := Evd.define gl.content new_constr !rdefs; + { subgoals = [new_goal] } + else + Util.error "convert-concl rule passed non-converting term" + + +(*** Bureaucracy in hypotheses ***) + +(* Renames a hypothesis. *) +let rename_hyp_sign id1 id2 sign = + Environ.apply_to_hyp_and_dependent_on sign id1 + (fun (_,b,t) _ -> (id2,b,t)) + (fun d _ -> map_named_declaration (replace_vars [id1,mkVar id2]) d) +let rename_hyp id1 id2 env rdefs gl info = + let hyps = hyps env rdefs gl info in + if id1 <> id2 && + List.mem id2 (Termops.ids_of_named_context (Environ.named_context_of_val hyps)) then + Util.error ((Names.string_of_id id2)^" is already used."); + let new_hyps = rename_hyp_sign id1 id2 hyps in + let new_env = Environ.reset_with_named_context new_hyps env in + let new_concl = Term.replace_vars [id1,mkVar id2] (concl env rdefs gl info) in + let new_subproof = Evarutil.e_new_evar rdefs new_env new_concl in + let new_subproof = Term.replace_vars [id2,mkVar id1] new_subproof in + let (new_evar,_) = Term.destEvar new_subproof in + let new_goal = descendent gl new_evar in + rdefs := Evd.define gl.content new_subproof !rdefs; + { subgoals = [new_goal] } + +(*** Additional functions ***) + +(* emulates List.map for functions of type + [Evd.evar_map -> 'a -> 'b * Evd.evar_map] on lists of type 'a, by propagating + new evar_map to next definition. *) +(*This sort of construction actually works with any monad (here the State monade + in Haskell). There is a generic construction in Haskell called mapM. +*) +let rec list_map f l s = + match l with + | [] -> ([],s) + | a::l -> let (a,s) = f s a in + let (l,s) = list_map f l s in + (a::l,s) + + +(* Layer to implement v8.2 tactic engine ontop of the new architecture. + Types are different from what they used to be due to a change of the + internal types. *) +module V82 = struct + + (* Old style env primitive *) + let env evars gl = + let evi = content evars gl in + Evd.evar_env evi + + (* For printing *) + let unfiltered_env evars gl = + let evi = content evars gl in + Evd.evar_unfiltered_env evi + + (* Old style hyps primitive *) + let hyps evars gl = + let evi = content evars gl in + evi.Evd.evar_hyps + + (* Access to ".evar_concl" *) + let concl evars gl = + let evi = content evars gl in + evi.Evd.evar_concl + + (* Access to ".evar_extra" *) + let extra evars gl = + let evi = content evars gl in + evi.Evd.evar_extra + + (* Old style filtered_context primitive *) + let filtered_context evars gl = + let evi = content evars gl in + Evd.evar_filtered_context evi + + (* Old style mk_goal primitive *) + let mk_goal evars hyps concl extra = + let evk = Evarutil.new_untyped_evar () in + let evi = { Evd.evar_hyps = hyps; + Evd.evar_concl = concl; + Evd.evar_filter = List.map (fun _ -> true) + (Environ.named_context_of_val hyps); + Evd.evar_body = Evd.Evar_empty; + Evd.evar_source = (Util.dummy_loc,Evd.GoalEvar); + Evd.evar_extra = extra } + in + let evi = Typeclasses.mark_unresolvable evi in + let evars = Evd.add evars evk evi in + let ids = List.map Util.pi1 (Environ.named_context_of_val hyps) in + let inst = Array.of_list (List.map mkVar ids) in + let ev = Term.mkEvar (evk,inst) in + (build evk, ev, evars) + + (* Equality function on goals *) + let equal evars gl1 gl2 = + let evi1 = content evars gl1 in + let evi2 = content evars gl2 in + Evd.eq_evar_info evi1 evi2 + + (* Creates a dummy [goal sigma] for use in auto *) + let dummy_goal = + (* This goal seems to be marshalled somewhere. Therefore it cannot be + marked unresolvable for typeclasses, as non-empty Store.t-s happen + to have functional content. *) + let evi = Evd.make_evar Environ.empty_named_context_val Term.mkProp in + let evk = Evarutil.new_untyped_evar () in + let sigma = Evd.add Evd.empty evk evi in + { Evd.it = build evk ; Evd.sigma = sigma } + + (* Makes a goal out of an evar *) + let build = build + + (* Instantiates a goal with an open term *) + let partial_solution sigma { content=evk } c = + Evd.define evk c sigma + + (* Parts of the progress tactical *) + let same_goal evars1 gl1 evars2 gl2 = + let evi1 = content evars1 gl1 in + let evi2 = content evars2 gl2 in + Term.eq_constr evi1.Evd.evar_concl evi2.Evd.evar_concl && + Environ.eq_named_context_val evi1.Evd.evar_hyps evi2.Evd.evar_hyps + + let weak_progress glss gls = + match glss.Evd.it with + | [ g ] -> not (same_goal glss.Evd.sigma g gls.Evd.sigma gls.Evd.it) + | _ -> true + + let progress glss gls = + weak_progress glss gls + (* spiwack: progress normally goes like this: + (Evd.progress_evar_map gls.Evd.sigma glss.Evd.sigma) || (weak_progress glss gls) + This is immensly slow in the current implementation. Maybe we could + reimplement progress_evar_map with restricted folds like "fold_undefined", + with a good implementation of them. + *) + + (* Used for congruence closure *) + let new_goal_with sigma gl new_hyps = + let evi = content sigma gl in + let new_evi = { evi with Evd.evar_hyps = new_hyps } in + let new_evi = Typeclasses.mark_unresolvable new_evi in + let evk = Evarutil.new_untyped_evar () in + let new_sigma = Evd.add Evd.empty evk new_evi in + { Evd.it = build evk ; sigma = new_sigma } + + (* Used by the typeclasses *) + let nf_evar sigma gl = + let evi = content sigma gl in + let evi = Evarutil.nf_evar_info sigma evi in + let sigma = Evd.add sigma gl.content evi in + (gl,sigma) + + (* Goal represented as a type, doesn't take into account section variables *) + let abstract_type sigma gl = + let (gl,sigma) = nf_evar sigma gl in + let env = env sigma gl in + let genv = Global.env () in + let is_proof_var decl = + try ignore (Environ.lookup_named (Util.pi1 decl) genv); false + with Not_found -> true in + Environ.fold_named_context_reverse (fun t decl -> + if is_proof_var decl then + mkNamedProd_or_LetIn decl t + else + t + ) ~init:(concl sigma gl) env + +end diff --git a/proofs/goal.mli b/proofs/goal.mli new file mode 100644 index 0000000000..49e3c9b1ae --- /dev/null +++ b/proofs/goal.mli @@ -0,0 +1,228 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* goal + +(* [advance sigma g] returns [Some g'] if [g'] is undefined and + is the current avatar of [g] (for instance [g] was changed by [clear] + into [g']). It returns [None] if [g] has been (partially) solved. *) +open Store.Field +val advance : Evd.evar_map -> goal -> goal option + + +(*** Goal tactics ***) + + +(* Goal tactics are [subgoal sensitive]-s *) +type subgoals = private { subgoals: goal list } + +(* Goal sensitive values *) +type +'a sensitive + +(* evaluates a goal sensitive value in a given goal (knowing the current evar_map). *) +val eval : 'a sensitive -> Environ.env -> Evd.evar_map -> goal -> 'a * Evd.evar_map + +(* monadic bind on sensitive expressions *) +val bind : 'a sensitive -> ('a -> 'b sensitive) -> 'b sensitive + +(* monadic return on sensitive expressions *) +val return : 'a -> 'a sensitive + + +(* interpretation of "open" constr *) +(* spiwack: it is a wrapper around [Constrintern.interp_open_constr]. + In an ideal world, this could/should be the other way round. + As of now, though, it seems at least quite useful to build tactics. *) +val interp_constr : Topconstr.constr_expr -> Term.constr sensitive + +(* Type of constr with holes used by refine. *) +type refinable + +module Refinable : sig + type t = refinable + type handle + + val make : (handle -> Term.constr sensitive) -> refinable sensitive + val make_with : (handle -> (Term.constr*'a) sensitive) -> (refinable*'a) sensitive + + val mkEvar : handle -> Environ.env -> Term.types -> Term.constr sensitive + + (* [with_type c typ] constrains term [c] to have type [typ]. *) + val with_type : Term.constr -> Term.types -> Term.constr sensitive + + val resolve_typeclasses : ?onlyargs:bool -> ?split:bool -> ?fail:bool -> unit -> unit sensitive + + + (* [constr_of_raw h check_type resolve_classes] is a pretyping function. + The [check_type] argument asks whether the term should have the same + type as the conclusion. [resolve_classes] is a flag on pretyping functions + which, if set to true, calls the typeclass resolver. + The principal argument is a [rawconstr] which is then pretyped in the + context of a term, the remaining evars are registered to the handle. + It is the main component of the toplevel refine tactic.*) + val constr_of_raw : + handle -> bool -> bool -> Rawterm.rawconstr -> Term.constr sensitive + +end + +(* [refine t] takes a refinable term and use it as a partial proof for current + goal. *) +val refine : refinable -> subgoals sensitive + + +(*** Cleaning goals ***) + +(* Implements the [clear] tactic *) +val clear : Names.identifier list -> subgoals sensitive + +(* Implements the [clearbody] tactic *) +val clear_body : Names.identifier list -> subgoals sensitive + + +(*** Conversion in goals ***) + +(* Changes an hypothesis of the goal with a convertible type and body. + Checks convertibility if the boolean argument is true. *) +val convert_hyp : bool -> Term.named_declaration -> subgoals sensitive + +(* Changes the conclusion of the goal with a convertible type and body. + Checks convertibility if the boolean argument is true. *) +val convert_concl : bool -> Term.constr -> subgoals sensitive + +(*** Bureaucracy in hypotheses ***) + +(* Renames a hypothesis. *) +val rename_hyp : Names.identifier -> Names.identifier -> subgoals sensitive + +(*** Sensitive primitives ***) + +(* [concl] is the conclusion of the current goal *) +val concl : Term.constr sensitive + +(* [hyps] is the [named_context_val] representing the hypotheses + of the current goal *) +val hyps : Environ.named_context_val sensitive + +(* [env] is the current [Environ.env] containing both the + environment in which the proof is ran, and the goal hypotheses *) +val env : Environ.env sensitive + +(* [defs] is the [Evd.evar_map] at the current evaluation point *) +val defs : Evd.evar_map sensitive + +(* These four functions serve as foundation for the goal sensitive part + of the tactic monad (see Proofview). + [here] is a special sort of [return]: [here g a] is the value [a], but + does not have any value (it raises an exception) if evaluated in + any other goal than [g]. + [here_list] is the same, except with a list of goals rather than a single one. + [plus a b] is the same as [a] if [a] is defined in the current goal, otherwise + it is [b]. Effectively it's defined in the goals where [a] and [b] are defined. + [null] is defined in no goal. (it is a neutral element for [plus]). *) +(* spiwack: these primitives are a bit hackish, but I couldn't find another way + to pass information between goals, like for an intro tactic which gives to + each goal the name of the variable it introduce. + In pratice, in my experience, the primitives given in Proofview (in terms of + [here] and [plus]) are sufficient to define any tactics, hence these might + be another example of communication primitives between Goal and Proofview. + Still, I can't see a way to prevent using the Proofview primitive to read + a goal sensitive value out of its valid context. *) +val null : 'a sensitive + +val plus : 'a sensitive -> 'a sensitive -> 'a sensitive + +val here : goal -> 'a -> 'a sensitive + +val here_list : goal list -> 'a -> 'a sensitive + +(*** Additional functions ***) + +(* emulates List.map for functions of type + [Evd.evar_map -> 'a -> 'b * Evd.evar_map] on lists of type 'a, by propagating + new evar_map to next definition *) +val list_map : (Evd.evar_map -> 'a -> 'b * Evd.evar_map) -> + 'a list -> + Evd.evar_map -> + 'b list *Evd.evar_map + +(* Layer to implement v8.2 tactic engine ontop of the new architecture. + Types are different from what they used to be due to a change of the + internal types. *) +module V82 : sig + + (* Old style env primitive *) + val env : Evd.evar_map -> goal -> Environ.env + + (* For printing *) + val unfiltered_env : Evd.evar_map -> goal -> Environ.env + + (* Old style hyps primitive *) + val hyps : Evd.evar_map -> goal -> Environ.named_context_val + + (* Access to ".evar_concl" *) + val concl : Evd.evar_map -> goal -> Term.constr + + (* Access to ".evar_extra" *) + val extra : Evd.evar_map -> goal -> Store.t + + (* Old style filtered_context primitive *) + val filtered_context : Evd.evar_map -> goal -> Sign.named_context + + (* Old style mk_goal primitive, returns a new goal with corresponding + hypotheses and conclusion, together with a term which is precisely + the evar corresponding to the goal, and an updated evar_map. *) + val mk_goal : Evd.evar_map -> + Environ.named_context_val -> + Term.constr -> + Store.t -> + goal * Term.constr * Evd.evar_map + + (* Equality function on goals *) + val equal : Evd.evar_map -> goal -> goal -> bool + + (* Creates a dummy [goal sigma] for use in auto *) + val dummy_goal : goal Evd.sigma + + (* Makes a goal out of an evar *) + (* spiwack: used by [Proofview.init], not entirely clean probably, but it is + the only way I could think of to preserve compatibility with previous Coq + stuff. *) + val build : Evd.evar -> goal + + + (* Instantiates a goal with an open term *) + val partial_solution : Evd.evar_map -> goal -> Term.constr -> Evd.evar_map + + (* Principal part of the weak-progress tactical *) + val weak_progress : goal list Evd.sigma -> goal Evd.sigma -> bool + + (* Principal part of the progress tactical *) + val progress : goal list Evd.sigma -> goal Evd.sigma -> bool + + (* Principal part of tclNOTSAMEGOAL *) + val same_goal : Evd.evar_map -> goal -> Evd.evar_map -> goal -> bool + + (* Used for congruence closure *) + val new_goal_with : Evd.evar_map -> goal -> Environ.named_context_val -> goal Evd.sigma + + (* Used by the typeclasses *) + val nf_evar : Evd.evar_map -> goal -> goal * Evd.evar_map + + (* Goal represented as a type, doesn't take into account section variables *) + val abstract_type : Evd.evar_map -> goal -> Term.types + +end diff --git a/proofs/logic.ml b/proofs/logic.ml index 11155d3698..7c092bb66e 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -21,7 +21,6 @@ open Reductionops open Inductive open Inductiveops open Typing -open Proof_trees open Proof_type open Typeops open Type_errors @@ -326,22 +325,18 @@ let goal_type_of env sigma c = (if !check then type_of else Retyping.get_type_of ~refresh:true) env sigma c let rec mk_refgoals sigma goal goalacc conclty trm = - let env = evar_env goal in - let hyps = goal.evar_hyps in - let mk_goal hyps concl = mk_goal hyps concl goal.evar_extra in -(* - if not (occur_meta trm) then - let t'ty = (unsafe_machine env sigma trm).uj_type in - let _ = conv_leq_goal env sigma trm t'ty conclty in - (goalacc,t'ty) - else -*) + let env = Goal.V82.env sigma goal in + let hyps = Goal.V82.hyps sigma goal in + let mk_goal hyps concl = + Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) + in match kind_of_term trm with | Meta _ -> let conclty = nf_betaiota sigma conclty in if !check && occur_meta conclty then raise (RefinerError (MetaInType conclty)); - (mk_goal hyps conclty)::goalacc, conclty + let (gl,ev,sigma) = mk_goal hyps conclty in + gl::goalacc, conclty, sigma, ev | Cast (t,_, ty) -> check_typability env sigma ty; @@ -349,30 +344,32 @@ let rec mk_refgoals sigma goal goalacc conclty trm = mk_refgoals sigma goal goalacc ty t | App (f,l) -> - let (acc',hdty) = + let (acc',hdty,sigma,applicand) = match kind_of_term f with | Ind _ | Const _ when (isInd f or has_polymorphic_type (destConst f)) -> (* Sort-polymorphism of definition and inductive types *) goalacc, - type_of_global_reference_knowing_conclusion env sigma f conclty + type_of_global_reference_knowing_conclusion env sigma f conclty, + sigma, f | _ -> mk_hdgoals sigma goal goalacc f in - let (acc'',conclty') = + let (acc'',conclty',sigma, args) = mk_arggoals sigma goal acc' hdty (Array.to_list l) in check_conv_leq_goal env sigma trm conclty' conclty; - (acc'',conclty') + (acc'',conclty',sigma, Term.mkApp (applicand, Array.of_list args)) - | Case (_,p,c,lf) -> - let (acc',lbrty,conclty') = mk_casegoals sigma goal goalacc p c in + | Case (ci,p,c,lf) -> + let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in check_conv_leq_goal env sigma trm conclty' conclty; - let acc'' = + let (acc'',sigma, rbranches) = array_fold_left2 - (fun lacc ty fi -> fst (mk_refgoals sigma goal lacc ty fi)) - acc' lbrty lf + (fun (lacc,sigma,bacc) ty fi -> + let (r,_,s,b') = mk_refgoals sigma goal lacc ty fi in r,s,(b'::bacc)) + (acc',sigma,[]) lbrty lf in - (acc'',conclty') + (acc'',conclty',sigma, Term.mkCase (ci,p',c',Array.of_list (List.rev rbranches))) | _ -> if occur_meta trm then @@ -380,70 +377,77 @@ let rec mk_refgoals sigma goal goalacc conclty trm = let t'ty = goal_type_of env sigma trm in check_conv_leq_goal env sigma trm t'ty conclty; - (goalacc,t'ty) + (goalacc,t'ty,sigma, trm) -(* Same as mkREFGOALS but without knowing te type of the term. Therefore, +(* Same as mkREFGOALS but without knowing the type of the term. Therefore, * Metas should be casted. *) and mk_hdgoals sigma goal goalacc trm = - let env = evar_env goal in - let hyps = goal.evar_hyps in - let mk_goal hyps concl = mk_goal hyps concl goal.evar_extra in + let env = Goal.V82.env sigma goal in + let hyps = Goal.V82.hyps sigma goal in + let mk_goal hyps concl = + Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in match kind_of_term trm with | Cast (c,_, ty) when isMeta c -> check_typability env sigma ty; - (mk_goal hyps (nf_betaiota sigma ty))::goalacc,ty + let (gl,ev,sigma) = mk_goal hyps (nf_betaiota sigma ty) in + gl::goalacc,ty,sigma,ev | Cast (t,_, ty) -> check_typability env sigma ty; mk_refgoals sigma goal goalacc ty t | App (f,l) -> - let (acc',hdty) = + let (acc',hdty,sigma,applicand) = if isInd f or isConst f & not (array_exists occur_meta l) (* we could be finer *) then - (goalacc,type_of_global_reference_knowing_parameters env sigma f l) + (goalacc,type_of_global_reference_knowing_parameters env sigma f l,sigma,f) else mk_hdgoals sigma goal goalacc f in - mk_arggoals sigma goal acc' hdty (Array.to_list l) + let (acc'',conclty',sigma, args) = + mk_arggoals sigma goal acc' hdty (Array.to_list l) in + (acc'',conclty',sigma, Term.mkApp (applicand, Array.of_list args)) - | Case (_,p,c,lf) -> - let (acc',lbrty,conclty') = mk_casegoals sigma goal goalacc p c in - let acc'' = + | Case (ci,p,c,lf) -> + let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in + let (acc'',sigma,rbranches) = array_fold_left2 - (fun lacc ty fi -> fst (mk_refgoals sigma goal lacc ty fi)) - acc' lbrty lf + (fun (lacc,sigma,bacc) ty fi -> + let (r,_,s,b') = mk_refgoals sigma goal lacc ty fi in r,s,(b'::bacc)) + (acc',sigma,[]) lbrty lf in - (acc'',conclty') + (acc'',conclty',sigma, Term.mkCase (ci,p',c',Array.of_list (List.rev rbranches))) | _ -> if !check && occur_meta trm then anomaly "refine called with a dependent meta"; - goalacc, goal_type_of env sigma trm + goalacc, goal_type_of env sigma trm, sigma, trm and mk_arggoals sigma goal goalacc funty = function - | [] -> goalacc,funty + | [] -> goalacc,funty,sigma, [] | harg::tlargs as allargs -> - let t = whd_betadeltaiota (evar_env goal) sigma funty in + let t = whd_betadeltaiota (Goal.V82.env sigma goal) sigma funty in match kind_of_term t with | Prod (_,c1,b) -> - let (acc',hargty) = mk_refgoals sigma goal goalacc c1 harg in - mk_arggoals sigma goal acc' (subst1 harg b) tlargs + let (acc',hargty,sigma,arg') = mk_refgoals sigma goal goalacc c1 harg in + let (acc'',fty, sigma', args) = + mk_arggoals sigma goal acc' (subst1 harg b) tlargs in + (acc'',fty,sigma',arg'::args) | LetIn (_,c1,_,b) -> mk_arggoals sigma goal goalacc (subst1 c1 b) allargs | _ -> raise (RefinerError (CannotApply (t,harg))) and mk_casegoals sigma goal goalacc p c = - let env = evar_env goal in - let (acc',ct) = mk_hdgoals sigma goal goalacc c in - let (acc'',pt) = mk_hdgoals sigma goal acc' p in + let env = Goal.V82.env sigma goal in + let (acc',ct,sigma,c') = mk_hdgoals sigma goal goalacc c in + let (acc'',pt,sigma,p') = mk_hdgoals sigma goal acc' p in let indspec = try find_mrectype env sigma ct with Not_found -> anomaly "mk_casegoals" in let (lbrty,conclty) = type_case_branches_with_names env indspec p c in - (acc'',lbrty,conclty) + (acc'',lbrty,conclty,sigma,p',c') let convert_hyp sign sigma (id,b,bt as d) = @@ -461,18 +465,6 @@ let convert_hyp sign sigma (id,b,bt as d) = d) in reorder_val_context env sign' !reorder -(* Normalizing evars in a goal. Called by tactic Local_constraints - (i.e. when the sigma of the proof tree changes). Detect if the - goal is unchanged *) -let norm_goal sigma gl = - let red_fun = Evarutil.nf_evar sigma in - let ncl = red_fun gl.evar_concl in - let ngl = - { gl with - evar_concl = ncl; - evar_hyps = map_named_val red_fun gl.evar_hyps } in - if Evd.eq_evar_info ngl gl then None else Some ngl - (************************************************************************) @@ -480,10 +472,12 @@ let norm_goal sigma gl = (* Primitive tactics are handled here *) let prim_refiner r sigma goal = - let env = evar_env goal in - let sign = goal.evar_hyps in - let cl = goal.evar_concl in - let mk_goal hyps concl = mk_goal hyps concl goal.evar_extra in + let env = Goal.V82.env sigma goal in + let sign = Goal.V82.hyps sigma goal in + let cl = Goal.V82.concl sigma goal in + let mk_goal hyps concl = + Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) + in match r with (* Logical rules *) | Intro id -> @@ -491,19 +485,23 @@ let prim_refiner r sigma goal = error "New variable is already declared"; (match kind_of_term (strip_outer_cast cl) with | Prod (_,c1,b) -> - let sg = mk_goal (push_named_context_val (id,None,c1) sign) + let (sg,ev,sigma) = mk_goal (push_named_context_val (id,None,c1) sign) (subst1 (mkVar id) b) in + let sigma = + Goal.V82.partial_solution sigma goal (mkNamedLambda id c1 ev) in ([sg], sigma) | LetIn (_,c1,t1,b) -> - let sg = + let (sg,ev,sigma) = mk_goal (push_named_context_val (id,Some c1,t1) sign) (subst1 (mkVar id) b) in + let sigma = + Goal.V82.partial_solution sigma goal (mkNamedLetIn id c1 t1 ev) in ([sg], sigma) | _ -> raise (RefinerError IntroNeedsProduct)) | Cut (b,replace,id,t) -> - let sg1 = mk_goal sign (nf_betaiota sigma t) in + let (sg1,ev1,sigma) = mk_goal sign (nf_betaiota sigma t) in let sign,cl,sigma = if replace then let nexthyp = get_hyp_after id (named_context_of_val sign) in @@ -515,7 +513,10 @@ let prim_refiner r sigma goal = (if !check && mem_named_context id (named_context_of_val sign) then error "New variable is already declared"; push_named_context_val (id,None,t) sign,cl,sigma) in - let sg2 = mk_goal sign cl in + let (sg2,ev2,sigma) = + Goal.V82.mk_goal sigma sign cl (Goal.V82.extra sigma goal) in + let oterm = Term.mkApp (Term.mkNamedLambda id t ev2 , [| ev1 |]) in + let sigma = Goal.V82.partial_solution sigma goal oterm in if b then ([sg1;sg2],sigma) else ([sg2;sg1],sigma) | FixRule (f,n,rest,j) -> @@ -545,9 +546,24 @@ let prim_refiner r sigma goal = ("Name "^string_of_id f^" already used in the environment"); mk_sign (push_named_context_val (f,None,ar) sign) oth | [] -> - List.map (fun (_,_,c) -> mk_goal sign c) all + Goal.list_map (fun sigma (_,_,c) -> + let (gl,ev,sig')= + Goal.V82.mk_goal sigma sign c + (Goal.V82.extra sigma goal) + in ((gl,ev),sig')) + all sigma in - (mk_sign sign all, sigma) + let (gls_evs,sigma) = mk_sign sign all in + let (gls,evs) = List.split gls_evs in + let ids = List.map pi1 all in + let evs = List.map (Term.subst_vars (List.rev ids)) evs in + let indxs = Array.of_list (List.map (fun n -> n-1) (List.map pi2 all)) in + let funnames = Array.of_list (List.map (fun i -> Name i) ids) in + let typarray = Array.of_list (List.map pi3 all) in + let bodies = Array.of_list evs in + let oterm = Term.mkFix ((indxs,0),(funnames,typarray,bodies)) in + let sigma = Goal.V82.partial_solution sigma goal oterm in + (gls,sigma) | Cofix (f,others,j) -> let rec check_is_coind env cl = @@ -572,32 +588,55 @@ let prim_refiner r sigma goal = with | Not_found -> mk_sign (push_named_context_val (f,None,ar) sign) oth) - | [] -> List.map (fun (_,c) -> mk_goal sign c) all + | [] -> Goal.list_map (fun sigma(_,c) -> + let (gl,ev,sigma) = + Goal.V82.mk_goal sigma sign c + (Goal.V82.extra sigma goal) + in + ((gl,ev),sigma)) + all sigma in - (mk_sign sign all, sigma) + let (gls_evs,sigma) = mk_sign sign all in + let (gls,evs) = List.split gls_evs in + let (ids,types) = List.split all in + let evs = List.map (Term.subst_vars (List.rev ids)) evs in + let funnames = Array.of_list (List.map (fun i -> Name i) ids) in + let typarray = Array.of_list types in + let bodies = Array.of_list evs in + let oterm = Term.mkCoFix (0,(funnames,typarray,bodies)) in + let sigma = Goal.V82.partial_solution sigma goal oterm in + (gls,sigma) | Refine c -> check_meta_variables c; - let (sgl,cl') = mk_refgoals sigma goal [] cl c in + let (sgl,cl',sigma,oterm) = mk_refgoals sigma goal [] cl c in let sgl = List.rev sgl in + let sigma = Goal.V82.partial_solution sigma goal oterm in (sgl, sigma) (* Conversion rules *) | Convert_concl (cl',_) -> check_typability env sigma cl'; if (not !check) || is_conv_leq env sigma cl' cl then - let sg = mk_goal sign cl' in + let (sg,ev,sigma) = mk_goal sign cl' in + let sigma = Goal.V82.partial_solution sigma goal ev in ([sg], sigma) else error "convert-concl rule passed non-converting term" | Convert_hyp (id,copt,ty) -> - ([mk_goal (convert_hyp sign sigma (id,copt,ty)) cl], sigma) + let (gl,ev,sigma) = mk_goal (convert_hyp sign sigma (id,copt,ty)) cl in + let sigma = Goal.V82.partial_solution sigma goal ev in + ([gl], sigma) (* And now the structural rules *) | Thin ids -> let (hyps,concl,nsigma) = clear_hyps sigma ids sign cl in - ([mk_goal hyps concl], nsigma) + let (gl,ev,sigma) = + Goal.V82.mk_goal nsigma hyps concl (Goal.V82.extra nsigma goal) + in + let sigma = Goal.V82.partial_solution sigma goal ev in + ([gl], sigma) | ThinBody ids -> let clear_aux env id = @@ -606,7 +645,8 @@ let prim_refiner r sigma goal = env' in let sign' = named_context_val (List.fold_left clear_aux env ids) in - let sg = mk_goal sign' cl in + let (sg,ev,sigma) = mk_goal sign' cl in + let sigma = Goal.V82.partial_solution sigma goal ev in ([sg], sigma) | Move (withdep, hfrom, hto) -> @@ -614,11 +654,15 @@ let prim_refiner r sigma goal = split_sign hfrom hto (named_context_of_val sign) in let hyps' = move_hyp withdep toleft (left,declfrom,right) hto in - ([mk_goal hyps' cl], sigma) + let (gl,ev,sigma) = mk_goal hyps' cl in + let sigma = Goal.V82.partial_solution sigma goal ev in + ([gl], sigma) | Order ord -> let hyps' = reorder_val_context env sign ord in - ([mk_goal hyps' cl], sigma) + let (gl,ev,sigma) = mk_goal hyps' cl in + let sigma = Goal.V82.partial_solution sigma goal ev in + ([gl], sigma) | Rename (id1,id2) -> if !check & id1 <> id2 && @@ -626,12 +670,19 @@ let prim_refiner r sigma goal = error ((string_of_id id2)^" is already used."); let sign' = rename_hyp id1 id2 sign in let cl' = replace_vars [id1,mkVar id2] cl in - ([mk_goal sign' cl'], sigma) + let (gl,ev,sigma) = mk_goal sign' cl' in + let ev = Term.replace_vars [(id2,mkVar id1)] ev in + let sigma = Goal.V82.partial_solution sigma goal ev in + ([gl], sigma) | Change_evars -> - match norm_goal sigma goal with - Some ngl -> ([ngl],sigma) - | None -> ([goal], sigma) + (* spiwack: a priori [Change_evars] is now devoid of operational content. + The new proof engine keeping the evar_map up to date at all time. + As a compatibility mesure I leave the rule. + It is possible that my assumption is wrong and some uses of + [Change_evars] are not subsumed by the new engine. In which + case something has to be done here. (Feb. 2010) *) + ([goal],sigma) (************************************************************************) (************************************************************************) @@ -671,77 +722,3 @@ let proof_variable_index x = | [] -> raise Not_found in aux 1 - -let prim_extractor subfun vl pft = - let cl = pft.goal.evar_concl in - match pft.ref with - | Some (Prim (Intro id), [spf]) -> - (match kind_of_term (strip_outer_cast cl) with - | Prod (_,ty,_) -> - let cty = subst_proof_vars vl ty in - mkLambda (Name id, cty, subfun (add_proof_var id vl) spf) - | LetIn (_,b,ty,_) -> - let cb = subst_proof_vars vl b in - let cty = subst_proof_vars vl ty in - mkLetIn (Name id, cb, cty, subfun (add_proof_var id vl) spf) - | _ -> error "Incomplete proof!") - - | Some (Prim (Cut (b,_,id,t)),[spf1;spf2]) -> - let spf1, spf2 = if b then spf1, spf2 else spf2, spf1 in - mkLetIn (Name id,subfun vl spf1,subst_proof_vars vl t, - subfun (add_proof_var id vl) spf2) - - | Some (Prim (FixRule (f,n,others,j)),spfl) -> - let firsts,lasts = list_chop j others in - let all = Array.of_list (firsts@(f,n,cl)::lasts) in - let lcty = Array.map (fun (_,_,ar) -> subst_proof_vars vl ar) all in - let names = Array.map (fun (f,_,_) -> Name f) all in - let vn = Array.map (fun (_,n,_) -> n-1) all in - let newvl = List.fold_left (fun vl (id,_,_) -> add_proof_var id vl) - (add_proof_var f vl) others in - let lfix = Array.map (subfun newvl) (Array.of_list spfl) in - mkFix ((vn,j),(names,lcty,lfix)) - - | Some (Prim (Cofix (f,others,j)),spfl) -> - let firsts,lasts = list_chop j others in - let all = Array.of_list (firsts@(f,cl)::lasts) in - let lcty = Array.map (fun (_,ar) -> subst_proof_vars vl ar) all in - let names = Array.map (fun (f,_) -> Name f) all in - let newvl = List.fold_left (fun vl (id,_)-> add_proof_var id vl) - (add_proof_var f vl) others in - let lfix = Array.map (subfun newvl) (Array.of_list spfl) in - mkCoFix (j,(names,lcty,lfix)) - - | Some (Prim (Refine c),spfl) -> - let mvl = collect_meta_variables c in - let metamap = List.combine mvl (List.map (subfun vl) spfl) in - let cc = subst_proof_vars vl c in - plain_instance metamap cc - - (* Structural and conversion rules do not produce any proof *) - | Some (Prim (Convert_concl (t,k)),[pf]) -> - if k = DEFAULTcast then subfun vl pf - else mkCast (subfun vl pf,k,subst_proof_vars vl cl) - | Some (Prim (Convert_hyp _),[pf]) -> - subfun vl pf - - | Some (Prim (Thin _),[pf]) -> - (* No need to make ids Anon in vl: subst_proof_vars take the most recent*) - subfun vl pf - - | Some (Prim (ThinBody _),[pf]) -> - subfun vl pf - - | Some (Prim (Move _|Order _),[pf]) -> - subfun vl pf - - | Some (Prim (Rename (id1,id2)),[pf]) -> - subfun (rebind id1 id2 vl) pf - - | Some (Prim Change_evars, [pf]) -> - subfun vl pf - - | Some _ -> anomaly "prim_extractor" - - | None-> error "prim_extractor handed incomplete proof" - diff --git a/proofs/logic.mli b/proofs/logic.mli index 0d56da382a..560e577366 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -38,9 +38,6 @@ val prim_refiner : prim_rule -> evar_map -> goal -> goal list * evar_map type proof_variable -val prim_extractor : - (proof_variable list -> proof_tree -> constr) - -> proof_variable list -> proof_tree -> constr val proof_variable_index : identifier -> proof_variable list -> int diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index f3658ad4b6..6da73c2f67 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -20,322 +20,115 @@ open Environ open Evd open Typing open Refiner -open Proof_trees open Tacexpr open Proof_type open Lib open Safe_typing -(*********************************************************************) -(* Managing the proofs state *) -(* Mainly contributed by C. Murthy *) -(*********************************************************************) +let refining = Proof_global.there_are_pending_proofs +let check_no_pending_proofs = Proof_global.check_no_pending_proof -type lemma_possible_guards = int list list +let get_current_proof_name = Proof_global.get_current_proof_name +let get_all_proof_names = Proof_global.get_all_proof_names -type proof_topstate = { - mutable top_end_tac : tactic option; - top_init_tac : tactic option; - top_compute_guard : lemma_possible_guards; - top_goal : goal; - top_strength : Decl_kinds.goal_kind; - top_hook : declaration_hook } +type lemma_possible_guards = Proof_global.lemma_possible_guards -let proof_edits = - (Edit.empty() : (identifier,pftreestate,proof_topstate) Edit.t) +let delete_proof = Proof_global.discard +let delete_current_proof = Proof_global.discard_current +let delete_all_proofs = Proof_global.discard_all -let get_all_proof_names () = Edit.dom proof_edits +let undo n = + let p = Proof_global.give_me_the_proof () in + for i = 1 to n do + Proof.undo p + done -let msg_proofs use_resume = - match Edit.dom proof_edits with - | [] -> (spc () ++ str"(No proof-editing in progress).") - | l -> (str"." ++ fnl () ++ str"Proofs currently edited:" ++ spc () ++ - (prlist_with_sep pr_spc pr_id (get_all_proof_names ())) ++ - str"." ++ - (if use_resume then (fnl () ++ str"Use \"Resume\" first.") - else (mt ())) -) - -let undo_default = 50 -let undo_limit = ref undo_default - -(*********************************************************************) -(* Functions for decomposing and modifying the proof state *) -(*********************************************************************) - -let get_state () = - match Edit.read proof_edits with - | None -> errorlabstrm "Pfedit.get_state" - (str"No focused proof" ++ msg_proofs true) - | Some(_,pfs,ts) -> (pfs,ts) - -let get_topstate () = snd(get_state()) -let get_pftreestate () = fst(get_state()) - -let get_end_tac () = let ts = get_topstate () in ts.top_end_tac - -let get_goal_context n = - let pftree = get_pftreestate () in - let goal = nth_goal_of_pftreestate n pftree in - (project goal, pf_env goal) - -let get_current_goal_context () = get_goal_context 1 - -let set_current_proof = Edit.focus proof_edits - -let resume_proof (loc,id) = +let current_proof_depth () = try - Edit.focus proof_edits id - with Invalid_argument "Edit.focus" -> - user_err_loc(loc,"Pfedit.set_proof",str"No such proof" ++ msg_proofs false) + let p = Proof_global.give_me_the_proof () in + Proof.V82.depth p + with Proof_global.NoCurrentProof -> -1 -let suspend_proof () = +(* [undo_todepth n] resets the proof to its nth step (does [undo (d-n)] where d + is the depth of the focus stack). *) +let undo_todepth n = try - Edit.unfocus proof_edits - with Invalid_argument "Edit.unfocus" -> - errorlabstrm "Pfedit.suspend_current_proof" - (str"No active proof" ++ (msg_proofs true)) - -let resume_last_proof () = - match (Edit.last_focused proof_edits) with - | None -> - errorlabstrm "resume_last" (str"No proof-editing in progress.") - | Some p -> - Edit.focus proof_edits p + undo ((current_proof_depth ()) - n ) + with Proof_global.NoCurrentProof when n=0 -> () -let get_current_proof_name () = - match Edit.read proof_edits with - | None -> - errorlabstrm "Pfedit.get_proof" - (str"No focused proof" ++ msg_proofs true) - | Some(na,_,_) -> na +let set_undo _ = () +let get_undo _ = None -let add_proof (na,pfs,ts) = - Edit.create proof_edits (na,pfs,ts,!undo_limit+1) -let delete_proof_gen = Edit.delete proof_edits - -let delete_proof (loc,id) = - try - delete_proof_gen id - with (UserError ("Edit.delete",_)) -> - user_err_loc - (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs false) - -let mutate f = - try - Edit.mutate proof_edits (fun _ pfs -> f pfs) - with Invalid_argument "Edit.mutate" -> - errorlabstrm "Pfedit.mutate" - (str"No focused proof" ++ msg_proofs true) - -let start (na,ts) = - let pfs = mk_pftreestate ts.top_goal in - let pfs = Option.fold_right solve_pftreestate ts.top_init_tac pfs in - add_proof(na,pfs,ts) +let start_proof id str hyps c ?init_tac ?compute_guard hook = + let goals = [ (Global.env_of_context hyps , c) ] in + let init_tac = Option.map Proofview.V82.tactic init_tac in + Proof_global.start_proof id str goals ?compute_guard hook; + Option.iter Proof_global.run_tactic init_tac let restart_proof () = - match Edit.read proof_edits with - | None -> - errorlabstrm "Pfedit.restart" - (str"No focused proof to restart" ++ msg_proofs true) - | Some(na,_,ts) -> - delete_proof_gen na; - start (na,ts); - set_current_proof na - -let proof_term () = - extract_pftreestate (get_pftreestate()) - -(* Detect is one has completed a subtree of the initial goal *) -let subtree_solved () = - let pts = get_pftreestate () in - is_complete_proof (proof_of_pftreestate pts) & - not (is_top_pftreestate pts) - -let tree_solved () = - let pts = get_pftreestate () in - is_complete_proof (proof_of_pftreestate pts) - -let top_tree_solved () = - let pts = get_pftreestate () in - is_complete_proof (proof_of_pftreestate (top_of_tree pts)) - -(*********************************************************************) -(* Undo functions *) -(*********************************************************************) - -let set_undo = function - | None -> undo_limit := undo_default - | Some n -> - if n>=0 then - undo_limit := n - else - error "Cannot set a negative undo limit" - -let get_undo () = Some !undo_limit - -let undo n = - try - Edit.undo proof_edits n; - (* needed because the resolution of a subtree is done in 2 steps - then a sequence of undo can lead to a focus on a completely solved - subtree - this solution only works properly if undoing one step *) - if subtree_solved() then Edit.undo proof_edits 1 - with (Invalid_argument "Edit.undo") -> - errorlabstrm "Pfedit.undo" (str"No focused proof" ++ msg_proofs true) - -(* Undo current focused proof to reach depth [n]. This is used in - [vernac_backtrack]. *) -let undo_todepth n = - try - Edit.undo_todepth proof_edits n - with (Invalid_argument "Edit.undo") -> - errorlabstrm "Pfedit.undo" (str"No focused proof" ++ msg_proofs true) - -(* Return the depth of the current focused proof stack, this is used - to put informations in coq prompt (in emacs mode). *) -let current_proof_depth() = - try - Edit.depth proof_edits - with (Invalid_argument "Edit.depth") -> -1 - -(*********************************************************************) -(* Proof cooking *) -(*********************************************************************) + let p = Proof_global.give_me_the_proof () in + try while true do + Proof.undo p + done with Proof.EmptyUndoStack -> () + +let resume_last_proof () = Proof_global.resume_last () +let resume_proof (_,id) = Proof_global.resume id +let suspend_proof () = Proof_global.suspend () + +let cook_proof hook = + let prf = Proof_global.give_me_the_proof () in + hook prf; + match Proof_global.close_proof () with + | (i,([e],cg,str,h)) -> (i,(e,cg,str,h)) + | _ -> Util.anomaly "Pfedit.cook_proof: more than one proof term." let xml_cook_proof = ref (fun _ -> ()) let set_xml_cook_proof f = xml_cook_proof := f -let cook_proof k = - let (pfs,ts) = get_state() - and ident = get_current_proof_name () in - let {evar_concl=concl} = ts.top_goal - and strength = ts.top_strength in - let pfterm = extract_pftreestate pfs in - !xml_cook_proof (strength,pfs); - k pfs; - (ident, - ({ const_entry_body = pfterm; - const_entry_type = Some concl; - const_entry_opaque = true; - const_entry_boxed = false}, - ts.top_compute_guard, strength, ts.top_hook)) - -let current_proof_statement () = - let ts = get_topstate() in - (get_current_proof_name (), ts.top_strength, - ts.top_goal.evar_concl, ts.top_hook) - -(*********************************************************************) -(* Abort functions *) -(*********************************************************************) - -let refining () = [] <> (Edit.dom proof_edits) - -let check_no_pending_proofs () = - if refining () then - errorlabstrm "check_no_pending_proofs" - (str"Proof editing in progress" ++ (msg_proofs false) ++ fnl() ++ - str"Use \"Abort All\" first or complete proof(s).") +let get_pftreestate () = + Proof_global.give_me_the_proof () -let delete_current_proof () = delete_proof_gen (get_current_proof_name ()) - -let delete_all_proofs () = Edit.clear proof_edits - -(*********************************************************************) -(* Modifying the end tactic of the current profftree *) -(*********************************************************************) let set_end_tac tac = - let top = get_topstate () in - top.top_end_tac <- Some tac - -(*********************************************************************) -(* Modifying the current prooftree *) -(*********************************************************************) - -let start_proof na str sign concl ?init_tac ?(compute_guard=[]) hook = - let top_goal = mk_goal sign concl None in - let ts = { - top_end_tac = None; - top_init_tac = init_tac; - top_compute_guard = compute_guard; - top_goal = top_goal; - top_strength = str; - top_hook = hook} - in - start(na,ts); - set_current_proof na - -let solve_nth k tac = - let pft = get_pftreestate () in - if not (List.mem (-1) (cursor_of_pftreestate pft)) then - mutate (solve_nth_pftreestate k tac) - else - error "cannot apply a tactic when we are descended behind a tactic-node" - -let by tac = mutate (solve_pftreestate tac) - -let instantiate_nth_evar_com n c = - mutate (Evar_refiner.instantiate_pf_com n c) + let tac = Proofview.V82.tactic tac in + Proof_global.set_endline_tactic tac -let traverse n = mutate (traverse n) - -(* [traverse_to path] - - Traverses the current proof to get to the location specified by - [path]. - - ALGORITHM: The algorithm works on reversed paths. One just has to remove - the common part on the reversed paths. - -*) - -let common_ancestor l1 l2 = - let rec common_aux l1 l2 = - match l1, l2 with - | a1::l1', a2::l2' when a1 = a2 -> common_aux l1' l2' - | _, _ -> List.rev l1, List.length l2 - in - common_aux (List.rev l1) (List.rev l2) - -let rec traverse_up = function - | 0 -> (function pf -> pf) - | n -> (function pf -> Refiner.traverse 0 (traverse_up (n - 1) pf)) - -let rec traverse_down = function - | [] -> (function pf -> pf) - | n::l -> (function pf -> Refiner.traverse n (traverse_down l pf)) - -let traverse_to path = - let up_and_down path pfs = - let cursor = cursor_of_pftreestate pfs in - let down_list, up_count = common_ancestor path cursor in - traverse_down down_list (traverse_up up_count pfs) - in - mutate (up_and_down path) - -(* traverse the proof tree until it reach the nth subgoal *) -let traverse_nth_goal n = mutate (nth_unproven n) - -let traverse_prev_unproven () = mutate prev_unproven - -let traverse_next_unproven () = mutate next_unproven +let get_goal_context i = + try + let p = Proof_global.give_me_the_proof () in + let { it=goals ; sigma = sigma } = Proof.V82.subgoals p in + let goal = List.nth goals (i-1) in + (sigma, Refiner.pf_env { it=goal ; sigma=sigma }) + with Proof_global.NoCurrentProof -> Util.error "No focused proof." -(* The goal focused on *) -let focus_n = ref 0 -let make_focus n = focus_n := n -let focus () = !focus_n -let focused_goal () = let n = !focus_n in if n=0 then 1 else n +let get_current_goal_context () = get_goal_context 1 -let reset_top_of_tree () = - mutate top_of_tree +let current_proof_statement () = + match Proof_global.V82.get_current_initial_conclusions () with + | (id,([concl],strength,hook)) -> id,strength,concl,hook + | _ -> Util.anomaly "Pfedit.current_proof_statement: more than one statement" + +let solve_nth ?(with_end_tac=false) gi tac = + try + let tac = Proofview.V82.tactic tac in + let tac = if with_end_tac then + Proof_global.with_end_tac tac + else + tac + in + Proof_global.run_tactic (Proofview.tclFOCUS gi gi tac) + with + | Proof_global.NoCurrentProof -> Util.error "No focused proof" + | Proofview.IndexOutOfRange | Failure "list_chop" -> + let msg = str "No such goal: " ++ int gi ++ str "." in + Util.errorlabstrm "" msg + +let by = solve_nth 1 + +let instantiate_nth_evar_com n com = + let pf = Proof_global.give_me_the_proof () in + Proof.V82.instantiate_evar n com pf -let reset_top_of_script () = - mutate (fun pts -> - try - up_until_matching_rule is_proof_instr pts - with Not_found -> top_of_tree pts) (**********************************************************************) (* Shortcut to build a term using tactics *) diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index acb852471d..9e24061d32 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -20,6 +20,7 @@ open Tacmach open Tacexpr (*i*) + (*s Several proofs can be opened simultaneously but at most one is focused at some time. The following functions work by side-effect on current set of open proofs. In this module, ``proofs'' means an @@ -57,17 +58,16 @@ val delete_all_proofs : unit -> unit val undo : int -> unit -(* Same as undo, but undoes the current proof stack to reach depth - [n]. This is used in [vernac_backtrack]. *) -val undo_todepth : int -> unit +(* [undo_todepth n] resets the proof to its nth step (does [undo (d-n)] where d + is the depth of the undo stack). *) +val undo_todepth : int -> unit (* Returns the depth of the current focused proof stack, this is used to put informations in coq prompt (in emacs mode). *) val current_proof_depth: unit -> int -(* [set_undo (Some n)] sets the size of the ``undo'' stack; [set_undo None] - sets the size to the default value (12) *) - +(* [set_undo (Some n)] used to set the size of the ``undo'' stack. + These function now do nothing and will disapear. *) val set_undo : int option -> unit val get_undo : unit -> int option @@ -78,7 +78,7 @@ val get_undo : unit -> int option systematically apply at initialization time (e.g. to start the proof of mutually dependent theorems) *) -type lemma_possible_guards = int list list +type lemma_possible_guards = Proof_global.lemma_possible_guards val start_proof : identifier -> goal_kind -> named_context_val -> constr -> @@ -110,22 +110,18 @@ val suspend_proof : unit -> unit it fails if there is no current proof of if it is not completed; it also tells if the guardness condition has to be inferred. *) -val cook_proof : (Refiner.pftreestate -> unit) -> +val cook_proof : (Proof.proof -> unit) -> identifier * - (Entries.definition_entry * lemma_possible_guards * goal_kind * - declaration_hook) + (Entries.definition_entry * lemma_possible_guards * goal_kind * + declaration_hook) (* To export completed proofs to xml *) -val set_xml_cook_proof : (goal_kind * pftreestate -> unit) -> unit +val set_xml_cook_proof : (goal_kind * Proof.proof -> unit) -> unit -(*s [get_pftreestate ()] returns the current focused pending proof or +(*s [get_Proof.proof ()] returns the current focused pending proof or raises [UserError "no focused proof"] *) -val get_pftreestate : unit -> pftreestate - -(* [get_end_tac ()] returns the current tactic to apply to all new subgoal *) - -val get_end_tac : unit -> tactic option +val get_pftreestate : unit -> Proof.proof (* [get_goal_context n] returns the context of the [n]th subgoal of the current focused proof or raises a [UserError] if there is no @@ -160,7 +156,7 @@ val set_end_tac : tactic -> unit current focused proof or raises a UserError if no proof is focused or if there is no [n]th subgoal *) -val solve_nth : int -> tactic -> unit +val solve_nth : ?with_end_tac:bool -> int -> tactic -> unit (* [by tac] applies tactic [tac] to the 1st subgoal of the current focused proof or raises a UserError if there is no focused proof or @@ -175,31 +171,6 @@ val by : tactic -> unit val instantiate_nth_evar_com : int -> Topconstr.constr_expr -> unit -(*s To deal with subgoal focus *) - -val make_focus : int -> unit -val focus : unit -> int -val focused_goal : unit -> int -val subtree_solved : unit -> bool -val tree_solved : unit -> bool -val top_tree_solved : unit -> bool - -val reset_top_of_tree : unit -> unit -val reset_top_of_script : unit -> unit - -val traverse : int -> unit -val traverse_nth_goal : int -> unit -val traverse_next_unproven : unit -> unit -val traverse_prev_unproven : unit -> unit - - -(* These two functions make it possible to implement more elaborate - proof and goal management, as it is done, for instance in pcoq *) - -val traverse_to : int list -> unit -val mutate : (pftreestate -> pftreestate) -> unit - - (* [build_by_tactic typ tac] returns a term of type [typ] by calling [tac] *) val build_constant_by_tactic : named_context_val -> types -> tactic -> diff --git a/proofs/proof.ml b/proofs/proof.ml new file mode 100644 index 0000000000..0c298cc630 --- /dev/null +++ b/proofs/proof.ml @@ -0,0 +1,294 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Proofview.proofview -> bool + +let next_kind = ref 0 +let new_focus_kind () = + let r = !next_kind in + incr next_kind; + r + +(* To be authorized to unfocus one must meet the condition prescribed by + the action which focused.*) +(* spiwack: we could consider having a list of authorized focus_kind instead + of just one, if anyone needs it *) +(* [no_cond] only checks that the unfocusing command uses the right + [focus_kind]. *) +let no_cond k0 k _ = k0 = k +(* [done_cond] checks that the unfocusing command uses the right [focus_kind] + and that the focused proofview is complete. *) +let done_cond k0 k p = k0 = k && Proofview.finished p + + +(* Subpart of the type of proofs. It contains the parts of the proof which + are under control of the undo mechanism *) +type proof_state = { + (* Current focused proofview *) + proofview: Proofview.proofview; + (* History of the focusings, provides information on how + to unfocus the proof. + The list is empty when the proof is fully unfocused. *) + focus_stack: (focus_condition*Proofview.focus_context) list; + (* Extra information which can be freely used to create new behaviours. *) + intel: Store.t +} + +type proof_info = { + mutable endline_tactic : unit Proofview.tactic ; + initial_conclusions : Term.types list +} + +type undo_action = + | State of proof_state + | Effect of (unit -> unit) + +type proof = { (* current proof_state *) + mutable state : proof_state; + (* The undo stack *) + mutable undo_stack : undo_action list; + info : proof_info + } + + +(*** General proof functions ***) + +let start goals = + { state = { proofview = Proofview.init goals ; + focus_stack = [] ; + intel = Store.empty} ; + undo_stack = [] ; + info = { endline_tactic = Proofview.tclUNIT (); + initial_conclusions = List.map snd goals } + } + +let rec unroll_focus pv = function + | (_,ctx)::stk -> unroll_focus (Proofview.unfocus ctx pv) stk + | [] -> pv + +(* spiwack: a proof is considered completed even if its still focused, if the focus + doesn't hide any goal. *) +let is_done p = + Proofview.finished p.state.proofview && + Proofview.finished (unroll_focus p.state.proofview p.state.focus_stack) + +(* spiwack: for compatibility with <= 8.2 proof engine *) +let has_unresolved_evar p = + Proofview.V82.has_unresolved_evar p.state.proofview + +(* Returns the list of partial proofs to initial goals *) +let partial_proof p = + List.map fst (Proofview.return p.state.proofview) + +exception UnfinishedProof +exception HasUnresolvedEvar +let return p = + if not (is_done p) then + raise UnfinishedProof + else if has_unresolved_evar p then + (* spiwack: for compatibility with <= 8.2 proof engine *) + raise HasUnresolvedEvar + else + Proofview.return p.state.proofview + +(*** The following functions implement the basic internal mechanisms + of proofs, they are not meant to be exported in the .mli ***) + +(* An auxiliary function to push a {!focus_context} on the focus stack. *) +let push_focus kind context pr = + pr.state <- { pr.state with focus_stack = (kind,context)::pr.state.focus_stack } + +exception FullyUnfocused + +(* An auxiliary function to read the kind of the next focusing step *) +let cond_of_focus pr = + match pr.state.focus_stack with + | (cond,_)::_ -> cond + | _ -> raise FullyUnfocused + +(* An auxiliary function to pop and read the last {!Proofview.focus_context} + on the focus stack. *) +let pop_focus pr = + match pr.state.focus_stack with + | focus::other_focuses -> + pr.state <- { pr.state with focus_stack = other_focuses }; focus + | _ -> + raise FullyUnfocused + +(* Auxiliary function to push a [proof_state] onto the undo stack. *) +let push_undo save ({ undo_stack = stack } as pr) = + pr.undo_stack <- save::stack + +(* Auxiliary function to pop and read a [save_state] from the undo stack. *) +exception EmptyUndoStack +let pop_undo pr = + match pr.undo_stack with + | state::stack -> pr.undo_stack <- stack; state + | _ -> raise EmptyUndoStack + + +(* This function focuses the proof [pr] between indices [i] and [j] *) +let _focus cond i j pr = + let (focused,context) = Proofview.focus i j pr.state.proofview in + push_focus cond context pr; + pr.state <- { pr.state with proofview = focused } + +(* This function unfocuses the proof [pr], it raises [CannotUnfocus], + if the proof is already fully unfocused. + This function does not care about the condition of the current focus. *) +let _unfocus pr = + let (_,fc) = pop_focus pr in + pr.state <- { pr.state with proofview = Proofview.unfocus fc pr.state.proofview } + + +(*** Endline tactic ***) + +(* spiwack this is an information about the UI, it might be a good idea to move + it to the Proof_global module *) + +(* Sets the tactic to be used when a tactic line is closed with [...] *) +let set_endline_tactic tac p = + p.info.endline_tactic <- tac + +let with_end_tac pr tac = + Proofview.tclTHEN tac pr.info.endline_tactic + +(*** The following functions define the safety mechanism of the + proof system, they may be unsafe if not used carefully. There is + currently no reason to export them in the .mli ***) + +(* This functions saves the current state into a [proof_state]. *) +let save_state { state = ps } = State ps + +(* This function stores the current proof state in the undo stack. *) +let save pr = + push_undo (save_state pr) pr + +(* This function restores a state, presumably from the top of the undo stack. *) +let restore_state save pr = + match save with + | State save -> pr.state <- save + | Effect undo -> undo () + +(* Interpretes the Undo command. *) +let undo pr = + (* On a single line, since the effects commute *) + restore_state (pop_undo pr) pr + +(* Adds an undo effect to the undo stack. Use it with care, errors here might result + in inconsistent states. *) +let add_undo effect pr = + push_undo (Effect effect) pr + +(* Focus command (focuses on the [i]th subgoal) *) +(* spiwack: there could also, easily be a focus-on-a-range tactic, is there + a need for it? *) +let focus cond i pr = + save pr; + _focus cond i i pr + +(* Unfocus command. + Fails if the proof is not focused. *) +let unfocus kind pr = + let starting_point = save_state pr in + try + let cond = cond_of_focus pr in + if cond kind pr.state.proofview then + (_unfocus pr; + push_undo starting_point pr) + else + Util.error "This proof is focused, but cannot be unfocused this way" + with FullyUnfocused -> + Util.error "This proof is not focused" + +let no_focused_goal p = + Proofview.finished p.state.proofview + +(*** Function manipulation proof extra informations ***) + +let get_proof_info pr = + pr.state.intel + +let set_proof_info info pr = + save pr; + pr.state <- { pr.state with intel=info } + + +(*** Tactics ***) + +let run_tactic env tac pr = + let starting_point = save_state pr in + let sp = pr.state.proofview in + try + let tacticced_proofview = Proofview.apply env tac sp in + pr.state <- { pr.state with proofview = tacticced_proofview }; + push_undo starting_point pr + with e -> + restore_state starting_point pr; + raise e + + + +(*** Compatibility layer with <=v8.2 ***) +module V82 = struct + let subgoals p = + Proofview.V82.goals p.state.proofview + + let background_subgoals p = + Proofview.V82.goals (unroll_focus p.state.proofview p.state.focus_stack) + + let get_initial_conclusions p = + p.info.initial_conclusions + + let depth p = List.length p.undo_stack + + let top_goal p = + let { Evd.it=gls ; sigma=sigma } = + Proofview.V82.top_goals p.state.proofview + in + { Evd.it=List.hd gls ; sigma=sigma } + + let instantiate_evar n com pr = + let starting_point = save_state pr in + let sp = pr.state.proofview in + try + let new_proofview = Proofview.V82.instantiate_evar n com sp in + pr.state <- { pr.state with proofview = new_proofview }; + push_undo starting_point pr + with e -> + restore_state starting_point pr; + raise e +end diff --git a/proofs/proof.mli b/proofs/proof.mli new file mode 100644 index 0000000000..2b1c3f5c20 --- /dev/null +++ b/proofs/proof.mli @@ -0,0 +1,133 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* proof + +(* Returns [true] is the considered proof is completed, that is if no goal remain + to be considered (this does not require that all evars have been solved). *) +val is_done : proof -> bool + +(* Returns the list of partial proofs to initial goals. *) +val partial_proof : proof -> Term.constr list + +(* Returns the proofs (with their type) of the initial goals. + Raises [UnfinishedProof] is some goals remain to be considered. + Raises [HasUnresolvedEvar] if some evars have been left undefined. *) +exception UnfinishedProof +exception HasUnresolvedEvar +val return : proof -> (Term.constr * Term.types) list + +(* Interpretes the Undo command. Raises [EmptyUndoStack] if + the undo stack is empty. *) +exception EmptyUndoStack +val undo : proof -> unit + +(* Adds an undo effect to the undo stack. Use it with care, errors here might result + in inconsistent states. *) +val add_undo : (unit -> unit) -> proof -> unit + +(*** Focusing actions ***) + +(* [focus_kind] is the type used by focusing and unfocusing + commands to synchronise. Focusing and unfocusing commands use + a particular focus_kind, and if they don't match, the unfocusing command + will fail. *) +type focus_kind +val new_focus_kind : unit -> focus_kind + +(* To be authorized to unfocus one must meet the condition prescribed by + the action which focused.*) +type focus_condition +(* [no_cond] only checks that the unfocusing command uses the right + [focus_kind]. *) +val no_cond : focus_kind -> focus_condition +(* [done_cond] checks that the unfocusing command uses the right [focus_kind] + and that the focused proofview is complete. *) +val done_cond : focus_kind -> focus_condition + +(* focus command (focuses on the [i]th subgoal) *) +(* there could also, easily be a focus-on-a-range tactic, is there + a need for it? *) +val focus : focus_condition -> int -> proof -> unit + +exception FullyUnfocused +(* Unfocusing command. + Raises [FullyUnfocused] if the proof is not focused. *) +val unfocus : focus_kind -> proof -> unit + +(* returns [true] if there is no goal under focus. *) +val no_focused_goal : proof -> bool + +(*** Function manipulation proof extra informations ***) + +val get_proof_info : proof -> Store.t + +val set_proof_info : Store.t -> proof -> unit + + +(*** Endline tactic ***) + +(* Sets the tactic to be used when a tactic line is closed with [...] *) +val set_endline_tactic : unit Proofview.tactic -> proof -> unit + +val with_end_tac : proof -> unit Proofview.tactic -> unit Proofview.tactic + +(*** Tactics ***) + +val run_tactic : Environ.env -> unit Proofview.tactic -> proof -> unit + + +(*** Compatibility layer with <=v8.2 ***) +module V82 : sig + val subgoals : proof -> Goal.goal list Evd.sigma + + (* All the subgoals of the proof, including those which are not focused. *) + val background_subgoals : proof -> Goal.goal list Evd.sigma + + val get_initial_conclusions : proof -> Term.types list + + val depth : proof -> int + + val top_goal : proof -> Goal.goal Evd.sigma + + (* Implements the Existential command *) + val instantiate_evar : int -> Topconstr.constr_expr -> proof -> unit +end diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml new file mode 100644 index 0000000000..420ff84325 --- /dev/null +++ b/proofs/proof_global.ml @@ -0,0 +1,295 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit ; + reset : unit -> unit +} + +let proof_modes = Hashtbl.create 6 +let register_proof_mode ({ name = n } as m) = Hashtbl.add proof_modes n m +(* initial mode: standard mode *) +let standard = { name = "No" ; set = (fun ()->()) ; reset = (fun () -> ()) } +let _ = register_proof_mode standard + +(* Default proof mode, to be set at the beginning of proofs. *) +let default_proof_mode = ref standard + +let set_default_proof_mode = + Goptions.declare_string_option {Goptions. + optsync = true ; + optname = "default proof mode" ; + optkey = ["Default";"Proof";"Mode"] ; + optread = begin fun () -> + let { name = name } = !default_proof_mode in name + end; + optwrite = begin fun n -> + default_proof_mode := Hashtbl.find proof_modes n + end + } + +(*** Proof Global Environment ***) + +(* local shorthand *) +type nproof = identifier*Proof.proof + +(* Extra info on proofs. *) +type lemma_possible_guards = int list list +type proof_info = { + strength : Decl_kinds.goal_kind ; + compute_guard : lemma_possible_guards; + hook :Tacexpr.declaration_hook ; + mode : proof_mode +} + +(* Invariant: a proof is at most in one of current_proof and suspended. And the + domain of proof_info is the union of that of current_proof and suspended.*) +(* The head of [!current_proof] is the actual current proof, the other ones are to + be resumed when the current proof is closed, aborted or suspended. *) +let current_proof = ref ([]:nproof list) +let suspended = ref ([] : nproof list) +let proof_info = ref (Idmap.empty : proof_info Idmap.t) + +(* Current proof_mode, for bookkeeping *) +let current_proof_mode = ref !default_proof_mode + +(* combinators for proof modes *) +let update_proof_mode () = + match !current_proof with + | (id,_)::_ -> + let { mode = m } = Idmap.find id !proof_info in + !current_proof_mode.reset (); + current_proof_mode := m; + !current_proof_mode.set () + | _ -> + !current_proof_mode.reset (); + current_proof_mode := standard + +(* combinators for the current_proof and suspended lists *) +let push a l = l := a::!l; + update_proof_mode () + +exception NoSuchProof +let rec extract id l = + let rec aux = function + | ((id',_) as np)::l when id_ord id id' = 0 -> (np,l) + | np::l -> let (np', l) = aux l in (np' , np::l) + | [] -> raise NoSuchProof + in + let (np,l') = aux !l in + l := l'; + update_proof_mode (); + np + +exception NoCurrentProof +let extract_top l = + match !l with + | np::l' -> l := l' ; update_proof_mode (); np + | [] -> raise NoCurrentProof +let find_top l = + match !l with + | np::_ -> np + | [] -> raise NoCurrentProof + +let rotate_top l1 l2 = + let np = extract_top l1 in + push np l2 + +let rotate_find id l1 l2 = + let np = extract id l1 in + push np l2 + + +(* combinators for the proof_info map *) +let add id info m = + m := Idmap.add id info !m +let remove id m = + m := Idmap.remove id !m + +(*** Proof Global manipulation ***) + +let get_all_proof_names () = + List.map fst !current_proof @ + List.map fst !suspended + +let give_me_the_proof () = + snd (find_top current_proof) + +let get_current_proof_name () = + fst (find_top current_proof) + +(* spiwack: it might be considered to move error messages away. + Or else to remove special exceptions from Proof_global. + Arguments for the former: there is no reason Proof_global is only + accessed directly through vernacular commands. Error message should be + pushed to external layers, and so we should be able to have a finer + control on error message on complex actions. *) +let msg_proofs use_resume = + match get_all_proof_names () with + | [] -> (spc () ++ str"(No proof-editing in progress).") + | l -> (str"." ++ fnl () ++ str"Proofs currently edited:" ++ spc () ++ + (Util.prlist_with_sep Util.pr_spc Nameops.pr_id l) ++ + str"." ++ + (if use_resume then (fnl () ++ str"Use \"Resume\" first.") + else (mt ())) + ) + + +let there_is_a_proof () = !current_proof <> [] +let there_are_suspended_proofs () = !suspended <> [] +let there_are_pending_proofs () = + there_is_a_proof () || + there_are_suspended_proofs () +let check_no_pending_proof () = + if not (there_are_pending_proofs ()) then + () + else begin + pp_with Format.str_formatter + (str"Proof editing in progress" ++ (msg_proofs false) ++ fnl() ++ + str"Use \"Abort All\" first or complete proof(s).") ; + Util.error (Format.flush_str_formatter ()) + end + + +let suspend () = + rotate_top current_proof suspended + +let resume_last () = + rotate_top suspended current_proof + +let resume id = + rotate_find id suspended current_proof + +let discard_gen id = + try + ignore (extract id current_proof); + remove id proof_info + with NoSuchProof -> ignore (extract id suspended) + +let discard (loc,id) = + try + discard_gen id + with NoSuchProof -> + Util.user_err_loc + (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs false) + +let discard_current () = + let (id,_) = extract_top current_proof in + remove id proof_info + +let discard_all () = + current_proof := []; + suspended := []; + proof_info := Idmap.empty + +(* [set_proof_mode] sets the proof mode to be used after it's called. It is + typically called by the Proof Mode command. *) +(* Core component. + No undo handling. + Applies to proof [id], and proof mode [m]. *) +let set_proof_mode m id = + let info = Idmap.find id !proof_info in + let info = { info with mode = m } in + proof_info := Idmap.add id info !proof_info; + update_proof_mode () +(* Complete function. + Handles undo. + Applies to current proof, and proof mode name [mn]. *) +let set_proof_mode mn = + let m = Hashtbl.find proof_modes mn in + let id = get_current_proof_name () in + let pr = give_me_the_proof () in + Proof.add_undo begin let curr = !current_proof_mode in fun () -> + set_proof_mode curr id ; update_proof_mode () + end pr ; + set_proof_mode m id + +(* [start_proof s str env t hook tac] starts a proof of name [s] and + conclusion [t]; [hook] is optionally a function to be applied at + proof end (e.g. to declare the built constructions as a coercion + or a setoid morphism); init_tac is possibly a tactic to + systematically apply at initialization time (e.g. to start the + proof of mutually dependent theorems). + It raises exception [ProofInProgress] if there is a proof being + currently edited. *) +let start_proof id str goals ?(compute_guard=[]) hook = + (* arnaud: ajouter une vérification pour la présence de id dans le proof_global *) + let p = Proof.start goals in + add id { strength=str ; + compute_guard=compute_guard ; + hook=hook ; + mode = ! default_proof_mode } proof_info ; + push (id,p) current_proof + +(* arnaud: à enlever *) +let run_tactic tac = + let p = give_me_the_proof () in + let env = Global.env () in + Proof.run_tactic env tac p + +(* Sets the tactic to be used when a tactic line is closed with [...] *) +let set_endline_tactic tac = + let p = give_me_the_proof () in + Proof.set_endline_tactic tac p + +let with_end_tac tac = + let p = give_me_the_proof () in + Proof.with_end_tac p tac + +let close_proof () = + (* spiwack: for now close_proof doesn't actually discard the proof, it is done + by [Command.save]. *) + try + let id = get_current_proof_name () in + let p = give_me_the_proof () in + let proofs_and_types = Proof.return p in + let entries = List.map (fun (c,t) -> { Entries.const_entry_body = c ; + const_entry_type = Some t; + const_entry_opaque = true ; + const_entry_boxed = false } ) + proofs_and_types + in + let { compute_guard=cg ; strength=str ; hook=hook } = + Idmap.find id !proof_info + in + (id, (entries,cg,str,hook)) + with + | Proof.UnfinishedProof -> + Util.error "Attempt to save an incomplete proof" + | Proof.HasUnresolvedEvar -> + Util.error "Attempt to save a proof with existential variables still non-instantiated" + +module V82 = struct + let get_current_initial_conclusions () = + let p = give_me_the_proof () in + let id = get_current_proof_name () in + let { strength=str ; hook=hook } = + Idmap.find id !proof_info + in + (id,(Proof.V82.get_initial_conclusions p, str, hook)) +end + diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli new file mode 100644 index 0000000000..84a61c755a --- /dev/null +++ b/proofs/proof_global.mli @@ -0,0 +1,89 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit ; + reset : unit -> unit +} +(* Registers a new proof mode which can then be adressed by name + in [set_default_proof_mode]. + One mode is already registered - the standard mode - named "No", + It corresponds to Coq default setting are they are set when coqtop starts. *) +val register_proof_mode : proof_mode -> unit + +val there_is_a_proof : unit -> bool +val there_are_pending_proofs : unit -> bool +val check_no_pending_proof : unit -> unit + +val get_current_proof_name : unit -> Names.identifier +val get_all_proof_names : unit -> Names.identifier list + +val discard : Names.identifier Util.located -> unit +val discard_current : unit -> unit +val discard_all : unit -> unit + +(* [set_proof_mode] sets the proof mode to be used after it's called. It is + typically called by the Proof Mode command. *) +val set_proof_mode : string -> unit + +exception NoCurrentProof +val give_me_the_proof : unit -> Proof.proof + + +(* [start_proof s str goals ~init_tac ~compute_guard hook] starts + a proof of name [s] and + conclusion [t]; [hook] is optionally a function to be applied at + proof end (e.g. to declare the built constructions as a coercion + or a setoid morphism). *) +type lemma_possible_guards = int list list +val start_proof : Names.identifier -> + Decl_kinds.goal_kind -> + (Environ.env * Term.types) list -> + ?compute_guard:lemma_possible_guards -> + Tacexpr.declaration_hook -> + unit + +val close_proof : unit -> + Names.identifier * + (Entries.definition_entry list * + lemma_possible_guards * + Decl_kinds.goal_kind * + Tacexpr.declaration_hook) + +val suspend : unit -> unit +val resume_last : unit -> unit +val resume : Names.identifier -> unit + +(* Runs a tactic on the current proof. Raises [NoCurrentProof] is there is + no current proof. *) +val run_tactic : unit Proofview.tactic -> unit + +(* Sets the tactic to be used when a tactic line is closed with [...] *) +val set_endline_tactic : unit Proofview.tactic -> unit + +(* Appends the endline tactic of the current proof to a tactic. *) +val with_end_tac : unit Proofview.tactic -> unit Proofview.tactic + +module V82 : sig + val get_current_initial_conclusions : unit -> Names.identifier *(Term.types list * Decl_kinds.goal_kind * Tacexpr.declaration_hook) +end diff --git a/proofs/proof_trees.ml b/proofs/proof_trees.ml deleted file mode 100644 index a5bd073a30..0000000000 --- a/proofs/proof_trees.ml +++ /dev/null @@ -1,107 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* true - | _ -> false -*) - -(* Functions on goals *) - -let mk_goal hyps cl extra = - { evar_hyps = hyps; evar_concl = cl; - evar_filter = List.map (fun _ -> true) (named_context_of_val hyps); - evar_body = Evar_empty; evar_source = (dummy_loc,GoalEvar); - evar_extra = extra } - -(* Functions on proof trees *) - -let ref_of_proof pf = - match pf.ref with - | None -> failwith "rule_of_proof" - | Some r -> r - -let rule_of_proof pf = - let (r,_) = ref_of_proof pf in r - -let children_of_proof pf = - let (_,cl) = ref_of_proof pf in cl - -let goal_of_proof pf = pf.goal - -let subproof_of_proof pf = match pf.ref with - | Some (Nested (_,pf), _) -> pf - | _ -> failwith "subproof_of_proof" - -let status_of_proof pf = pf.open_subgoals - -let is_complete_proof pf = pf.open_subgoals = 0 - -let is_leaf_proof pf = (pf.ref = None) - -let is_tactic_proof pf = match pf.ref with - | Some (Nested (Tactic _,_),_) -> true - | _ -> false - - -let pf_lookup_name_as_displayed env ccl s = - Detyping.lookup_name_as_displayed env ccl s - -let pf_lookup_index_as_renamed env ccl n = - Detyping.lookup_index_as_renamed env ccl n - -(* Functions on rules (Proof mode) *) - -let is_dem_rule = function - Decl_proof _ -> true - | _ -> false - -let is_proof_instr = function - Nested(Proof_instr (_,_),_) -> true - | _ -> false - -let is_focussing_command = function - Decl_proof b -> b - | Nested (Proof_instr (b,_),_) -> b - | _ -> false - - -(*********************************************************************) -(* Pretty printing functions *) -(*********************************************************************) - -open Pp - -let db_pr_goal g = - let env = evar_env g in - let penv = print_named_context env in - let pc = print_constr_env env g.evar_concl in - str" " ++ hv 0 (penv ++ fnl () ++ - str "============================" ++ fnl () ++ - str" " ++ pc) ++ fnl () - diff --git a/proofs/proof_trees.mli b/proofs/proof_trees.mli deleted file mode 100644 index 6d1fc143d3..0000000000 --- a/proofs/proof_trees.mli +++ /dev/null @@ -1,48 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr -> Dyn.t option -> goal - -val rule_of_proof : proof_tree -> rule -val ref_of_proof : proof_tree -> (rule * proof_tree list) -val children_of_proof : proof_tree -> proof_tree list -val goal_of_proof : proof_tree -> goal -val subproof_of_proof : proof_tree -> proof_tree -val status_of_proof : proof_tree -> int -val is_complete_proof : proof_tree -> bool -val is_leaf_proof : proof_tree -> bool -val is_tactic_proof : proof_tree -> bool - -val pf_lookup_name_as_displayed : env -> constr -> identifier -> int option -val pf_lookup_index_as_renamed : env -> constr -> int -> int option - -val is_proof_instr : rule -> bool -val is_focussing_command : rule -> bool - -(*s Pretty printing functions. *) - -(*i*) -open Pp -(*i*) - -val db_pr_goal : goal -> std_ppcmds diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml index bc29534081..2fffa39527 100644 --- a/proofs/proof_type.ml +++ b/proofs/proof_type.ml @@ -16,7 +16,7 @@ open Libnames open Term open Util open Tacexpr -open Decl_expr +(* open Decl_expr *) open Rawterm open Genarg open Nametab @@ -26,6 +26,10 @@ open Pattern (* This module defines the structure of proof tree and the tactic type. So, it is used by Proof_tree and Refiner *) +type goal = Goal.goal + +type tactic = goal sigma -> goal list sigma + type prim_rule = | Intro of identifier | Cut of bool * bool * identifier * types @@ -54,13 +58,6 @@ and rule = and compound_rule= | Tactic of tactic_expr * bool - | Proof_instr of bool*proof_instr (* the boolean is for focus restrictions *) - -and goal = evar_info - -and tactic = goal sigma -> (goal list sigma * validation) - -and validation = (proof_tree list -> proof_tree) and tactic_expr = (constr, diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli index b5c4a234d1..9692f19bc9 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.mli @@ -16,7 +16,6 @@ open Libnames open Term open Util open Tacexpr -open Decl_expr open Rawterm open Genarg open Nametab @@ -26,6 +25,10 @@ open Pattern (* This module defines the structure of proof tree and the tactic type. So, it is used by [Proof_tree] and [Refiner] *) +type goal = Goal.goal + +type tactic = goal sigma -> goal list sigma + type prim_rule = | Intro of identifier | Cut of bool * bool * identifier * types @@ -89,13 +92,6 @@ and rule = and compound_rule= (* the boolean of Tactic tells if the default tactic is used *) | Tactic of tactic_expr * bool - | Proof_instr of bool * proof_instr - -and goal = evar_info - -and tactic = goal sigma -> (goal list sigma * validation) - -and validation = (proof_tree list -> proof_tree) and tactic_expr = (constr, diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 05b86b1a04..66001e77a5 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -1,12 +1,15 @@ +Goal +Evar_refiner +Proofview +Proof +Proof_global Tacexpr Proof_type Redexpr -Proof_trees Logic Refiner -Evar_refiner Tacmach Pfedit Tactic_debug +Clenv Clenvtac -Decl_mode diff --git a/proofs/proofview.ml b/proofs/proofview.ml new file mode 100644 index 0000000000..a08941df03 --- /dev/null +++ b/proofs/proofview.ml @@ -0,0 +1,491 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* { initial = [] ; + solution = Evd.empty ; + comb = [] + } + | (env,typ)::l -> let { initial = ret ; solution = sol ; comb = comb } = + aux l + in + let ( new_defs , econstr ) = + Evarutil.new_evar sol env typ + in + let (e,_) = Term.destEvar econstr in + let gl = Goal.build e in + { initial = (econstr,typ)::ret; + solution = new_defs ; + comb = gl::comb } + in + fun l -> let v = aux l in + (* Marks all the goal unresolvable for typeclasses. *) + { v with solution = Typeclasses.mark_unresolvables v.solution } + +(* Returns whether this proofview is finished or not. That is, + if it has empty subgoals in the comb. There could still be unsolved + subgoaled, but they would then be out of the view, focused out. *) +let finished = function + | {comb = []} -> true + | _ -> false + +(* Returns the current value of the proofview partial proofs. *) +let return { initial=init; solution=defs } = + List.map (fun (c,t) -> (Evarutil.nf_evar defs c , t)) init + +(* spiwack: this function should probably go in the Util section, + but I'd rather have Util (or a separate module for lists) + raise proper exceptions before *) +(* [IndexOutOfRange] occurs in case of malformed indices + with respect to list lengths. *) +exception IndexOutOfRange + +(* [list_goto i l] returns a pair of lists [c,t] where + [c] has length [i] and is the reversed of the [i] first + elements of [l], and [t] is the rest of the list. + The idea is to navigate through the list, [c] is then + seen as the context of the current position. + Raises [IndexOutOfRange] if [i > length l]*) +let list_goto = + let rec aux acc index = function + | l when index = 0-> (acc,l) + | [] -> raise IndexOutOfRange + | a::q -> aux (a::acc) (index-1) q + in + fun i l -> + if i < 0 then + raise IndexOutOfRange + else + aux [] i l + +(* Type of the object which allow to unfocus a view.*) +(* First component is a reverse list of what comes before + and second component is what goes after (in the expected + order) *) +type focus_context = Goal.goal list * Goal.goal list + +(* This (internal) function extracts a sublist between two indices, and + returns this sublist together with its context: + if it returns [(a,(b,c))] then [a] is the sublist and (rev b)@a@c is the + original list. + The focused list has lenght [j-i-1] and contains the goals from + number [i] to number [j] (both included) the first goal of the list + being numbered [1]. + [focus_sublist i j l] raises [IndexOutOfRange] if + [i > length l], or [j > length l] or [ j < i ]. *) +let focus_sublist i j l = + let (left,sub_right) = list_goto (i-1) l in + let (sub, right) = + try + Util.list_chop (j-i+1) sub_right + with Failure "list_chop" -> + Util.errorlabstrm "nth_unproven" (Pp.str"Not such unproven subgoal") + in + (sub, (left,right)) + +(* Inverse operation to the previous one. *) +let unfocus_sublist (left,right) s = + List.rev_append left (s@right) + + +(* [focus i j] focuses a proofview on the goals from index [i] to index [j] + (inclusive). (i.e. goals number [i] to [j] become the only goals of the + returned proofview). + It returns the focus proof, and a context for the focus trace. *) +let focus i j sp = + let (new_comb, context) = focus_sublist i j sp.comb in + ( { sp with comb = new_comb } , context ) + +(* Unfocuses a proofview with respect to a context. *) +let undefined defs l = + Option.List.flatten (List.map (Goal.advance defs) l) +let unfocus c sp = + { sp with comb = undefined sp.solution (unfocus_sublist c sp.comb) } + + +(* The tactic monad: + - Tactics are objects which apply a transformation to all + the subgoals of the current view at the same time. By opposed + to the old vision of applying it to a single goal. It mostly + allows to consider tactic like [reorder] to reorder the goals + in the current view (which might be useful for the tactic designer) + (* spiwack: the ordering of goals, though, is perhaps a bit + brittle. It would be much more interesting to find a more + robust way to adress goals, I have no idea at this time + though*) + or global automation tactic for dependent subgoals (instantiating + an evar has influences on the other goals of the proof in progress, + not being able to take that into account causes the current eauto + tactic to fail on some instances where it could succeed). + - Tactics are a monad ['a tactic], in a sense a tactic can be + seens as a function (without argument) which returns a value + of type 'a and modifies the environement (in our case: the view). + Tactics of course have arguments, but these are given at the + meta-level as OCaml functions. + Most tactics, in the sense we are used to, return [ () ], that is + no really interesting values. But some might pass information + around; the [(>>--)] and [(>>==)] bind-like construction are the + main ingredients of this information passing. + (* spiwack: I don't know how much all this relates to F. Kirchner and + C. Muñoz. I wasn't able to understand how they used the monad + structure in there developpement. + *) + The tactics seen in Coq's Ltac are (for now at least) only + [unit tactic], the return values are kept for the OCaml toolkit. + The operation or the monad are [Proofview.tclUNIT] (which is the + "return" of the tactic monad) [Proofview.tclBIND] (which is + the "bind", also noted [(>=)]) and [Proofview.tclTHEN] (which is a + specialized bind on unit-returning tactics). +*) + +(* type of tactics *) +(* spiwack: double-continuation backtracking monads are reasonable + folklore for "search" implementations (including Tac interactive prover's + tactics). Yet it's quite hard to wrap your head around these. + I recommand reading a few times the "Backtracking, Interleaving, and Terminating + Monad Transformers" paper by O. Kiselyov, C. Chen, D. Fridman. + The peculiar shape of the monadic type is reminiscent of that of the continuation + monad transformer. + A good way to get a feel of what's happening is to look at what happens when + executing [apply (tclUNIT ())]. + The disjunction function is unlike that of the LogicT paper, because we want and + need to backtrack over state as well as values. Therefore we cannot be + polymorphic over the inner monad. *) +type proof_step = { goals : Goal.goal list ; defs : Evd.evar_map } +type +'a result = { proof_step : proof_step ; + content : 'a } + +(* nb=non-backtracking *) +type +'a nb_tactic = proof_step -> 'a result + +(* double-continutation backtracking *) +(* "sk" stands for "success continuation", "fk" for "failure continuation" *) +type 'r fk = exn -> 'r +type (-'a,'r) sk = 'a -> 'r fk -> 'r +type +'a tactic0 = { go : 'r. ('a, 'r nb_tactic) sk -> 'r nb_tactic fk -> 'r nb_tactic } + +(* We obtain a tactic by parametrizing with an environment *) +(* spiwack: alternatively the environment could be part of the "nb_tactic" state + monad. As long as we do not intend to change the environment during a tactic, + it's probably better here. *) +type +'a tactic = Environ.env -> 'a tactic0 + +(* unit of [nb_tactic] *) +let nb_tac_unit a step = { proof_step = step ; content = a } + +(* Applies a tactic to the current proofview. *) +let apply env t sp = + let start = { goals = sp.comb ; defs = sp.solution } in + let res = (t env).go (fun a _ step -> nb_tac_unit a step) (fun e _ -> raise e) start in + let next = res.proof_step in + {sp with + solution = next.defs ; + comb = next.goals + } + +(*** tacticals ***) + + +(* Unit of the tactic monad *) +let tclUNIT a _ = { go = fun sk fk step -> sk a fk step } + +(* Bind operation of the tactic monad *) +let tclBIND t k env = { go = fun sk fk step -> + (t env).go (fun a fk -> (k a env).go sk fk) fk step +} + +(* Interpretes the ";" (semicolon) of Ltac. + As a monadic operation, it's a specialized "bind" + on unit-returning tactic (meaning "there is no value to bind") *) +let tclTHEN t1 t2 env = { go = fun sk fk step -> + (t1 env).go (fun () fk -> (t2 env).go sk fk) fk step +} + +(* [tclIGNORE t] has the same operational content as [t], + but drops the value at the end. *) +let tclIGNORE tac env = { go = fun sk fk step -> + (tac env).go (fun _ fk -> sk () fk) fk step +} + +(* [tclOR t1 t2 = t1] if t1 succeeds and [tclOR t1 t2 = t2] if t1 fails. + No interleaving for the moment. *) +(* spiwack: compared to the LogicT paper, we backtrack at the same state + where [t1] has been called, not the state where [t1] failed. *) +let tclOR t1 t2 env = { go = fun sk fk step -> + (t1 env).go sk (fun _ _ -> (t2 env).go sk fk step) step +} + +(* [tclZERO e] always fails with error message [e]*) +let tclZERO e env = { go = fun _ fk step -> fk e step } + + +(* Focusing operation on proof_steps. *) +let focus_proof_step i j ps = + let (new_subgoals, context) = focus_sublist i j ps.goals in + ( { ps with goals = new_subgoals } , context ) + +(* Unfocusing operation of proof_steps. *) +let unfocus_proof_step c ps = + { ps with + goals = undefined ps.defs (unfocus_sublist c ps.goals) + } + +(* Focuses a tactic at a range of subgoals, found by their indices. *) +(* arnaud: bug if 0 goals ! *) +let tclFOCUS i j t env = { go = fun sk fk step -> + let (focused,context) = focus_proof_step i j step in + (t env).go (fun a fk step -> sk a fk (unfocus_proof_step context step)) fk focused +} + +(* Dispatch tacticals are used to apply a different tactic to each goal under + consideration. They come in two flavours: + [tclDISPATCH] takes a list of [unit tactic]-s and build a [unit tactic]. + [tclDISPATCHS] takes a list of ['a sensitive tactic] and returns and returns + and ['a sensitive tactic] where the ['a sensitive] interpreted in a goal [g] + corresponds to that of the tactic which created [g]. + It is to be noted that the return value of [tclDISPATCHS ts] makes only + sense in the goals immediatly built by it, and would cause an anomaly + is used otherwise. *) +exception SizeMismatch +(* spiwack: we use an parametrised function to generate the dispatch tacticals. + [tclDISPATCHGEN] takes a [null] argument to generate the return value + if there are no goal under focus, and a [join] argument to explain how + the return value at two given lists of subgoals are combined when + both lists are being concatenated. + [join] and [null] need be some sort of comutative monoid. *) +let rec tclDISPATCHGEN null join tacs env = { go = fun sk fk step -> + match tacs,step.goals with + | [] , [] -> (tclUNIT null env).go sk fk step + | t::tacs , first::goals -> + (tclDISPATCHGEN null join tacs env).go + begin fun x fk step -> + match Goal.advance step.defs first with + | None -> sk x fk step + | Some first -> + (t env).go + begin fun y fk step' -> + sk (join x y) fk { step' with + goals = step'.goals@step.goals + } + end + fk + { step with goals = [first] } + end + fk + { step with goals = goals } + | _ -> raise SizeMismatch +} + +(* takes a tactic which can raise exception and makes it pure by *failing* + on with these exceptions. Does not catch anomalies. *) +let purify t = + let t' env = { go = fun sk fk step -> try (t env).go (fun x -> sk (Util.Inl x)) fk step + with Util.Anomaly _ as e -> raise e + | e -> sk (Util.Inr e) fk step + } + in + tclBIND t' begin function + | Util.Inl x -> tclUNIT x + | Util.Inr e -> tclZERO e + end +let tclDISPATCHGEN null join tacs = purify (tclDISPATCHGEN null join tacs) + +let unitK () () = () +let tclDISPATCH = tclDISPATCHGEN () unitK + +let extend_to_list = + let rec copy n x l = + if n < 0 then raise SizeMismatch + else if n = 0 then l + else copy (n-1) x (x::l) + in + fun startxs rx endxs l -> + let ns = List.length startxs in + let ne = List.length endxs in + let n = List.length l in + startxs@(copy (n-ne-ns) rx endxs) +let tclEXTEND tacs1 rtac tacs2 env = { go = fun sk fk step -> + let tacs = extend_to_list tacs1 rtac tacs2 step.goals in + (tclDISPATCH tacs env).go sk fk step +} + +(* [tclGOALBIND] and [tclGOALBINDU] are sorts of bind which take a + [Goal.sensitive] as a first argument, the tactic then acts on each goal separately. + Allows backtracking between goals. *) +let list_of_sensitive s k env step = + Goal.list_map begin fun defs g -> + let (a,defs) = Goal.eval s env defs g in + (k a) , defs + end step.goals step.defs +(* In form of a tactic *) +let list_of_sensitive s k env = { go = fun sk fk step -> + let (tacs,defs) = list_of_sensitive s k env step in + sk tacs fk { step with defs = defs } +} + +(* This is a helper function for the dispatching tactics (like [tclGOALBIND] and + [tclDISPATCHS]). It takes an ['a sensitive] value, and returns a tactic + whose return value is, again, ['a sensitive] but only has value in the + (unmodified) goals under focus. *) +let here_s b env = { go = fun sk fk step -> + sk (Goal.bind (Goal.here_list step.goals b) (fun b -> b)) fk step +} + +let rec tclGOALBIND s k = + (* spiwack: the first line ensures that the value returned by the tactic [k] will + not "escape its scope". *) + let k a = tclBIND (k a) here_s in + purify begin + tclBIND (list_of_sensitive s k) begin fun tacs -> + tclDISPATCHGEN Goal.null Goal.plus tacs + end + end + +(* spiwack: this should probably be moved closer to the [tclDISPATCH] tactical. *) +let tclDISPATCHS tacs = + let tacs = + List.map begin fun tac -> + tclBIND tac here_s + end tacs + in + purify begin + tclDISPATCHGEN Goal.null Goal.plus tacs + end + +let rec tclGOALBINDU s k = + purify begin + tclBIND (list_of_sensitive s k) begin fun tacs -> + tclDISPATCHGEN () unitK tacs + end + end + +(* spiwack: up to a few details, same errors are in the Logic module. + this should be maintained synchronized, probably. *) +open Pretype_errors +let rec catchable_exception = function + | Stdpp.Exc_located(_,e) -> catchable_exception e + | Util.UserError _ | Type_errors.TypeError _ + | Indrec.RecursionSchemeError _ + | Nametab.GlobalizationError _ | PretypeError (_,VarNotFound _) + (* unification errors *) + | PretypeError(_,(CannotUnify _|CannotUnifyLocal _|CannotGeneralize _ + |NoOccurrenceFound _|CannotUnifyBindingType _|NotClean _ + |CannotFindWellTypedAbstraction _ + |UnsolvableImplicit _)) -> true + | Typeclasses_errors.TypeClassError + (_, Typeclasses_errors.UnsatisfiableConstraints _) -> true + | _ -> false + +(* No backtracking can happen here, hence, as opposed to the dispatch tacticals, + everything is done in one step. *) +let sensitive_on_step s env step = + let wrap g ((defs, partial_list) as partial_res) = + match Goal.advance defs g with + | None ->partial_res + | Some g -> + let {Goal.subgoals = sg } , d' = Goal.eval s env defs g in + (d',sg::partial_list) + in + let ( new_defs , combed_subgoals ) = + List.fold_right wrap step.goals (step.defs,[]) + in + { defs = new_defs; + goals = List.flatten combed_subgoals } +let tclSENSITIVE s = + purify begin + fun env -> { go = fun sk fk step -> sk () fk (sensitive_on_step s env step) } + end + +module Notations = struct + let (>-) = Goal.bind + let (>>-) = tclGOALBINDU + let (>>--) = tclGOALBIND + let (>=) = tclBIND + let (>>=) t k = t >= fun s -> s >>- k + let (>>==) t k = t >= fun s -> s >>-- k + let (<*>) = tclTHEN + let (<+>) = tclOR +end + +(*** Compatibility layer with <= 8.2 tactics ***) +module V82 = struct + type tac = Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + + let tactic tac _ = { go = fun sk fk ps -> + (* spiwack: we ignore the dependencies between goals here, expectingly + preserving the semantics of <= 8.2 tactics *) + let tac evd gl = + let glsigma = tac { Evd.it = gl ; Evd.sigma = evd } in + let sigma = glsigma.Evd.sigma in + let g = glsigma.Evd.it in + ( g , sigma ) + in + (* Old style tactics expect the goals normalized with respect to evars. *) + let (initgoals,initevd) = + Goal.list_map Goal.V82.nf_evar ps.goals ps.defs + in + let (goalss,evd) = Goal.list_map tac initgoals initevd in + let sgs = List.flatten goalss in + sk () fk { defs = evd ; goals = sgs } +} + + let has_unresolved_evar pv = + let evd = pv.solution in + (* arnaud: essayer une procédure moins coûteuse *) + not ((Evarutil.non_instantiated evd) = []) + + (* Returns the open goals of the proofview together with the evar_map to + interprete them. *) + let goals { comb = comb ; solution = solution } = + { Evd.it = comb ; sigma = solution} + + let top_goals { initial=initial ; solution=solution } = + let goals = List.map (fun (t,_) -> Goal.V82.build (fst (Term.destEvar t))) initial in + { Evd.it = goals ; sigma=solution } + + let instantiate_evar n com pv = + let (evk,_) = + let evl = Evarutil.non_instantiated pv.solution in + if (n <= 0) then + Util.error "incorrect existential variable index" + else if List.length evl < n then + Util.error "not so many uninstantiated existential variables" + else + List.nth evl (n-1) + in + { pv with + solution = Evar_refiner.instantiate_pf_com evk com pv.solution } + + let purify = purify +end diff --git a/proofs/proofview.mli b/proofs/proofview.mli new file mode 100644 index 0000000000..cd5520d4e5 --- /dev/null +++ b/proofs/proofview.mli @@ -0,0 +1,203 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* proofview + +(* Returns whether this proofview is finished or not.That is, + if it has empty subgoals in the comb. There could still be unsolved + subgoaled, but they would then be out of the view, focused out. *) +val finished : proofview -> bool + +(* Returns the current value of the proofview partial proofs. *) +val return : proofview -> (constr*types) list + + +(*** Focusing operations ***) + +(* [IndexOutOfRange] occurs in case of malformed indices + with respect to list lengths. *) +exception IndexOutOfRange + +(* Type of the object which allow to unfocus a view.*) +type focus_context + +(* [focus i j] focuses a proofview on the goals from index [i] to index [j] + (inclusive). (i.e. goals number [i] to [j] become the only goals of the + returned proofview). + It returns the focus proof, and a context for the focus trace. *) +val focus : int -> int -> proofview -> proofview * focus_context + +(* Unfocuses a proofview with respect to a context. *) +val unfocus : focus_context -> proofview -> proofview + +(* The tactic monad: + - Tactics are objects which apply a transformation to all + the subgoals of the current view at the same time. By opposed + to the old vision of applying it to a single goal. It mostly + allows to consider tactic like [reorder] to reorder the goals + in the current view (which might be useful for the tactic designer) + (* spiwack: the ordering of goals, though, is actually rather + brittle. It would be much more interesting to find a more + robust way to adress goals, I have no idea at this time + though*) + or global automation tactic for dependent subgoals (instantiating + an evar has influences on the other goals of the proof in progress, + not being able to take that into account causes the current eauto + tactic to fail on some instances where it could succeed). + - Tactics are a monad ['a tactic], in a sense a tactic can be + seens as a function (without argument) which returns a value + of type 'a and modifies the environement (in our case: the view). + Tactics of course have arguments, but these are given at the + meta-level as OCaml functions. + Most tactics in the sense we are used to return [ () ], that is + no really interesting values. But some might, to pass information + around; for instance [Proofview.freeze] allows to store a certain + goal sensitive value "at the present time" (which means, considering the + structure of the dynamics of proofs, [Proofview.freeze s] will have, + for every current goal [gl], and for any of its descendent [g'] in + the future the same value in [g'] that in [gl]). + (* spiwack: I don't know how much all this relates to F. Kirchner and + C. Muñoz. I wasn't able to understand how they used the monad + structure in there developpement. + *) + The tactics seen in Coq's Ltac are (for now at least) only + [unit tactic], the return values are kept for the OCaml toolkit. + The operation or the monad are [Proofview.tclIDTAC] (which is the + "return" of the tactic monad) [Proofview.tclBIND] (which is + the "bind") and [Proofview.tclTHEN] (which is a specialized + bind on unit-returning tactics). +*) + + +type +'a tactic + +(* Applies a tactic to the current proofview. *) +val apply : Environ.env -> 'a tactic -> proofview -> proofview + +(*** tacticals ***) + +(* Unit of the tactic monad *) +val tclUNIT : 'a -> 'a tactic + +(* Bind operation of the tactic monad *) +val tclBIND : 'a tactic -> ('a -> 'b tactic) -> 'b tactic + +(* Interpetes the ";" (semicolon) of Ltac. + As a monadic operation, it's a specialized "bind" + on unit-returning tactic (meaning "there is no value to bind") *) +val tclTHEN : unit tactic -> 'a tactic -> 'a tactic + +(* [tclIGNORE t] has the same operational content as [t], + but drops the value at the end. *) +val tclIGNORE : 'a tactic -> unit tactic + +(* [tclOR t1 t2 = t1] if t1 succeeds and [tclOR t1 t2 = t2] if t2 fails. + No interleaving at this point. *) +val tclOR : 'a tactic -> 'a tactic -> 'a tactic + +(* [tclZERO] always fails *) +val tclZERO : exn -> 'a tactic + +(* Focuses a tactic at a range of subgoals, found by their indices. *) +val tclFOCUS : int -> int -> 'a tactic -> 'a tactic + +(* Dispatch tacticals are used to apply a different tactic to each goal under + consideration. They come in two flavours: + [tclDISPATCH] takes a list of [unit tactic]-s and build a [unit tactic]. + [tclDISPATCHS] takes a list of ['a sensitive tactic] and returns and returns + and ['a sensitive tactic] where the ['a sensitive] interpreted in a goal [g] + corresponds to that of the tactic which created [g]. + It is to be noted that the return value of [tclDISPATCHS ts] makes only + sense in the goals immediatly built by it, and would cause an anomaly + is used otherwise. *) +val tclDISPATCH : unit tactic list -> unit tactic +val tclDISPATCHS : 'a Goal.sensitive tactic list -> 'a Goal.sensitive tactic + +(* [tclEXTEND b r e] is a variant to [tclDISPATCH], where the [r] tactic + is "repeated" enough time such that every goal has a tactic assigned to it + ([b] is the list of tactics applied to the first goals, [e] to the last goals, and [r] + is applied to every goal in between. *) +val tclEXTEND : unit tactic list -> unit tactic -> unit tactic list -> unit tactic + +(* A sort of bind which takes a [Goal.sensitive] as a first argument, + the tactic then acts on each goal separately. + Allows backtracking between goals. *) +val tclGOALBIND : 'a Goal.sensitive -> ('a -> 'b Goal.sensitive tactic) -> 'b Goal.sensitive tactic +val tclGOALBINDU : 'a Goal.sensitive -> ('a -> unit tactic) -> unit tactic + +(* [tclSENSITIVE] views goal-type tactics as a special kind of tactics.*) +val tclSENSITIVE : Goal.subgoals Goal.sensitive -> unit tactic + +(* Notations for building tactics. *) +module Notations : sig + (* Goal.bind *) + val (>-) : 'a Goal.sensitive -> ('a -> 'b Goal.sensitive) -> 'b Goal.sensitive + (* tclGOALBINDU *) + val (>>-) : 'a Goal.sensitive -> ('a -> unit tactic) -> unit tactic + (* tclGOALBIND *) + val (>>--) : 'a Goal.sensitive -> ('a -> 'b Goal.sensitive tactic) -> 'b Goal.sensitive tactic + + (* tclBIND *) + val (>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic + + (* [(>>=)] (and its goal sensitive variant [(>>==)]) "binds" in one step the + tactic monad and the goal-sensitive monad. + It is strongly advised to use it everytieme an ['a Goal.sensitive tactic] + needs a bind, since it usually avoids to delay the interpretation of the + goal sensitive value to a location where it does not make sense anymore. *) + val (>>=) : 'a Goal.sensitive tactic -> ('a -> unit tactic) -> unit tactic + val (>>==) : 'a Goal.sensitive tactic -> ('a -> 'b Goal.sensitive tactic) -> 'b Goal.sensitive tactic + + (* tclTHEN *) + val (<*>) : unit tactic -> 'a tactic -> 'a tactic + (* tclOR *) + val (<+>) : 'a tactic -> 'a tactic -> 'a tactic +end + +(*** Compatibility layer with <= 8.2 tactics ***) +module V82 : sig + type tac = Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + val tactic : tac -> unit tactic + + val has_unresolved_evar : proofview -> bool + + (* Returns the open goals of the proofview together with the evar_map to + interprete them. *) + val goals : proofview -> Goal.goal list Evd.sigma + + val top_goals : proofview -> Goal.goal list Evd.sigma + + (* Implements the Existential command *) + val instantiate_evar : int -> Topconstr.constr_expr -> proofview -> proofview + + (* spiwack: [purify] might be useful while writing tactics manipulating exception + explicitely or from the [V82] submodule (neither being advised, though *) + val purify : 'a tactic -> 'a tactic +end diff --git a/proofs/refiner.ml b/proofs/refiner.ml index a320b67cda..ffb18f2655 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -18,53 +18,20 @@ open Sign open Environ open Reductionops open Type_errors -open Proof_trees open Proof_type open Logic -type transformation_tactic = proof_tree -> (goal list * validation) - -let hypotheses gl = gl.evar_hyps -let conclusion gl = gl.evar_concl let sig_it x = x.it let project x = x.sigma -let pf_status pf = pf.open_subgoals - -let is_complete pf = (0 = (pf_status pf)) - -let on_open_proofs f pf = if is_complete pf then pf else f pf let and_status = List.fold_left (+) 0 (* Getting env *) -let pf_env gls = Global.env_of_context (sig_it gls).evar_hyps -let pf_hyps gls = named_context_of_val (sig_it gls).evar_hyps - - -let descend n p = - match p.ref with - | None -> error "It is a leaf." - | Some(r,pfl) -> - if List.length pfl >= n then - (match list_chop (n-1) pfl with - | left,(wanted::right) -> - (wanted, - (fun pfl' -> - if false (* debug *) then assert - (List.length pfl'=1 & (List.hd pfl').goal = wanted.goal); - let pf' = List.hd pfl' in - let spfl = left@(pf'::right) in - let newstatus = and_status (List.map pf_status spfl) in - { p with - open_subgoals = newstatus; - ref = Some(r,spfl) })) - | _ -> assert false) - else - error "Too few subproofs" - +let pf_env gls = Global.env_of_context (Goal.V82.hyps (project gls) (sig_it gls)) +let pf_hyps gls = named_context_of_val (Goal.V82.hyps (project gls) (sig_it gls)) (* [mapshape [ l1 ; ... ; lk ] [ v1 ; ... ; vk ] [ p_1 ; .... ; p_(l1+...+lk) ]] gives @@ -80,121 +47,9 @@ let rec mapshape nl (fl : (proof_tree list -> proof_tree) list) let m,l = list_chop h l in (List.hd fl m) :: (mapshape t (List.tl fl) l) -(* [frontier : proof_tree -> goal list * validation] - given a proof [p], [frontier p] gives [(l,v)] where [l] is the list of goals - to be solved to complete the proof, and [v] is the corresponding - validation *) - -let rec frontier p = - match p.ref with - | None -> - ([p.goal], - (fun lp' -> - let p' = List.hd lp' in - if Evd.eq_evar_info p'.goal p.goal then - p' - else - errorlabstrm "Refiner.frontier" - (str"frontier was handed back a ill-formed proof."))) - | Some(r,pfl) -> - let gll,vl = List.split(List.map frontier pfl) in - (List.flatten gll, - (fun retpfl -> - let pfl' = mapshape (List.map List.length gll) vl retpfl in - { p with - open_subgoals = and_status (List.map pf_status pfl'); - ref = Some(r,pfl')})) - -(* TODO LEM: I might have to make sure that these hooks are called - only when called from solve_nth_pftreestate; I can build the hook - call into the "f", then. - *) -let solve_hook = ref ignore -let set_solve_hook = (:=) solve_hook - -let rec frontier_map_rec f n p = - if n < 1 || n > p.open_subgoals then p else - match p.ref with - | None -> - let p' = f p in - if Evd.eq_evar_info p'.goal p.goal then - begin - !solve_hook p'; - p' - end - else - errorlabstrm "Refiner.frontier_map" - (str"frontier_map was handed back a ill-formed proof.") - | Some(r,pfl) -> - let (_,rpfl') = - List.fold_left - (fun (n,acc) p -> (n-p.open_subgoals,frontier_map_rec f n p::acc)) - (n,[]) pfl in - let pfl' = List.rev rpfl' in - { p with - open_subgoals = and_status (List.map pf_status pfl'); - ref = Some(r,pfl')} - -let frontier_map f n p = - let nmax = p.open_subgoals in - let n = if n < 0 then nmax + n + 1 else n in - if n < 1 || n > nmax then - errorlabstrm "Refiner.frontier_map" (str "No such subgoal"); - frontier_map_rec f n p - -let rec frontier_mapi_rec f i p = - if p.open_subgoals = 0 then p else - match p.ref with - | None -> - let p' = f i p in - if Evd.eq_evar_info p'.goal p.goal then - begin - !solve_hook p'; - p' - end - else - errorlabstrm "Refiner.frontier_mapi" - (str"frontier_mapi was handed back a ill-formed proof.") - | Some(r,pfl) -> - let (_,rpfl') = - List.fold_left - (fun (n,acc) p -> (n+p.open_subgoals,frontier_mapi_rec f n p::acc)) - (i,[]) pfl in - let pfl' = List.rev rpfl' in - { p with - open_subgoals = and_status (List.map pf_status pfl'); - ref = Some(r,pfl')} - -let frontier_mapi f p = frontier_mapi_rec f 1 p - -(* [list_pf p] is the lists of goals to be solved in order to complete the - proof [p] *) - -let list_pf p = fst (frontier p) - -let rec nb_unsolved_goals pf = pf.open_subgoals - -(* leaf g is the canonical incomplete proof of a goal g *) - -let leaf g = - { open_subgoals = 1; - goal = g; - ref = None } - -(* refiner r is a tactic applying the rule r *) - -let check_subproof_connection gl spfl = - list_for_all2eq (fun g pf -> Evd.eq_evar_info g pf.goal) gl spfl - -let abstract_operation syntax semantics gls = - let (sgl_sigma,validation) = semantics gls in - let hidden_proof = validation (List.map leaf sgl_sigma.it) in - (sgl_sigma, - fun spfl -> - assert (check_subproof_connection sgl_sigma.it spfl); - { open_subgoals = and_status (List.map pf_status spfl); - goal = gls.it; - ref = Some(Nested(syntax,hidden_proof),spfl)}) + +let abstract_operation syntax semantics = + semantics let abstract_tactic_expr ?(dflt=false) te tacfun gls = abstract_operation (Tactic(te,dflt)) tacfun gls @@ -207,16 +62,11 @@ let abstract_extended_tactic ?(dflt=false) s args = abstract_tactic ~dflt (Tacexpr.TacExtend (dummy_loc, s, args)) let refiner = function - | Prim pr as r -> + | Prim pr -> let prim_fun = prim_refiner pr in (fun goal_sigma -> let (sgl,sigma') = prim_fun goal_sigma.sigma goal_sigma.it in - ({it=sgl; sigma = sigma'}, - (fun spfl -> - assert (check_subproof_connection sgl spfl); - { open_subgoals = and_status (List.map pf_status spfl); - goal = goal_sigma.it; - ref = Some(r,spfl) }))) + {it=sgl; sigma = sigma'}) | Nested (_,_) | Decl_proof _ -> @@ -226,83 +76,15 @@ let refiner = function | Daimon -> fun gls -> - ({it=[];sigma=gls.sigma}, - fun spfl -> - assert (spfl=[]); - { open_subgoals = 0; - goal = gls.it; - ref = Some(Daimon,[])}) + {it=[];sigma=gls.sigma} let norm_evar_tac gl = refiner (Prim Change_evars) gl -let norm_evar_proof sigma pf = - let nf_subgoal i sgl = - let (gll,v) = norm_evar_tac {it=sgl.goal;sigma=sigma} in - v (List.map leaf gll.it) in - frontier_mapi nf_subgoal pf - -(* [extract_open_proof : proof_tree -> constr * (int * constr) list] - takes a (not necessarly complete) proof and gives a pair (pfterm,obl) - where pfterm is the constr corresponding to the proof - and [obl] is an [int*constr list] [ (m1,c1) ; ... ; (mn,cn)] - where the mi are metavariables numbers, and ci are their types. - Their proof should be completed in order to complete the initial proof *) - -let extract_open_proof sigma pf = - let next_meta = - let meta_cnt = ref 0 in - let rec f () = - incr meta_cnt; - if Evd.mem sigma (existential_of_int !meta_cnt) then f () - else !meta_cnt - in f - in - let open_obligations = ref [] in - let rec proof_extractor vl = function - | {ref=Some(Prim _,_)} as pf -> prim_extractor proof_extractor vl pf - - | {ref=Some(Nested(_,hidden_proof),spfl)} -> - let sgl,v = frontier hidden_proof in - let flat_proof = v spfl in - proof_extractor vl flat_proof - - | {ref=Some(Decl_proof _,[pf])} -> (proof_extractor vl) pf - - | {ref=(None|Some(Daimon,[]));goal=goal} -> - let visible_rels = - map_succeed - (fun id -> - try let n = proof_variable_index id vl in (n,id) - with Not_found -> failwith "caught") - (ids_of_named_context (named_context_of_val goal.evar_hyps)) in - let sorted_rels = - Sort.list (fun (n1,_) (n2,_) -> n1 > n2 ) visible_rels in - let sorted_env = - List.map (fun (n,id) -> (n,lookup_named_val id goal.evar_hyps)) - sorted_rels in - let abs_concl = - List.fold_right (fun (_,decl) c -> mkNamedProd_or_LetIn decl c) - sorted_env goal.evar_concl in - let inst = List.filter (fun (_,(_,b,_)) -> b = None) sorted_env in - let meta = next_meta () in - open_obligations := (meta,abs_concl):: !open_obligations; - applist (mkMeta meta, List.map (fun (n,_) -> mkRel n) inst) - - | _ -> anomaly "Bug: a case has been forgotten in proof_extractor" - in - let pfterm = proof_extractor [] pf in - (pfterm, List.rev !open_obligations) - (*********************) (* Tacticals *) (*********************) -(* unTAC : tactic -> goal sigma -> proof sigma *) - -let unTAC tac g = - let (gl_sigma,v) = tac g in - { it = v (List.map leaf gl_sigma.it); sigma = gl_sigma.sigma } let unpackage glsig = (ref (glsig.sigma)),glsig.it @@ -310,13 +92,9 @@ let repackage r v = {it=v;sigma = !r} let apply_sig_tac r tac g = check_for_interrupt (); (* Breakpoint *) - let glsigma,v = tac (repackage r g) in + let glsigma = tac (repackage r g) in r := glsigma.sigma; - (glsigma.it,v) - -let idtac_valid = function - [pf] -> pf - | _ -> anomaly "Refiner.idtac_valid" + glsigma.it (* [goal_goal_list : goal sigma -> goal list sigma] *) let goal_goal_list gls = {it=[gls.it];sigma=gls.sigma} @@ -325,7 +103,7 @@ let goal_goal_list gls = {it=[gls.it];sigma=gls.sigma} let tclNORMEVAR = norm_evar_tac (* identity tactic without any message *) -let tclIDTAC gls = (goal_goal_list gls, idtac_valid) +let tclIDTAC gls = goal_goal_list gls (* the message printing identity tactic *) let tclIDTAC_MESSAGE s gls = @@ -344,23 +122,21 @@ let tclFAIL_lazy lvl s g = raise (FailError (lvl,s)) let start_tac gls = let (sigr,g) = unpackage gls in - (sigr,[g],idtac_valid) + (sigr,[g]) -let finish_tac (sigr,gl,p) = (repackage sigr gl, p) +let finish_tac (sigr,gl) = repackage sigr gl (* Apply [taci.(i)] on the first n subgoals and [tac] on the others *) -let thens3parts_tac tacfi tac tacli (sigr,gs,p) = +let thens3parts_tac tacfi tac tacli (sigr,gs) = let nf = Array.length tacfi in let nl = Array.length tacli in let ng = List.length gs in if ng apply_sig_tac sigr (if i=ng-nl then tacli.(nl-ng+i) else tac)) 0 gs) in - (sigr, List.flatten gll, - compose p (mapshape (List.map List.length gll) pl)) + (sigr,List.flatten gll) (* Apply [taci.(i)] on the first n subgoals and [tac] on the others *) let thensf_tac taci tac = thens3parts_tac taci tac [||] @@ -369,10 +145,10 @@ let thensf_tac taci tac = thens3parts_tac taci tac [||] let thensl_tac tac taci = thens3parts_tac [||] tac taci (* Apply [tac i] on the ith subgoal (no subgoals number check) *) -let thensi_tac tac (sigr,gs,p) = - let gll,pl = - List.split (list_map_i (fun i -> apply_sig_tac sigr (tac i)) 1 gs) in - (sigr, List.flatten gll, compose p (mapshape (List.map List.length gll) pl)) +let thensi_tac tac (sigr,gs) = + let gll = + list_map_i (fun i -> apply_sig_tac sigr (tac i)) 1 gs in + (sigr, List.flatten gll) let then_tac tac = thensf_tac [||] tac @@ -382,7 +158,7 @@ let non_existent_goal n = (* Apply tac on the i-th goal (if i>0). If i<0, then start counting from the last goal (i=-1). *) -let theni_tac i tac ((_,gl,_) as subgoals) = +let theni_tac i tac ((_,gl) as subgoals) = let nsg = List.length gl in let k = if i < 0 then nsg + i + 1 else i in if nsg < 1 then errorlabstrm "theni_tac" (str"No more subgoals.") @@ -451,42 +227,29 @@ let rec tclTHENLIST = function let tclMAP tacfun l = List.fold_right (fun x -> (tclTHEN (tacfun x))) l tclIDTAC -(* various progress criterions *) -let same_goal gl subgoal = - eq_constr (conclusion subgoal) (conclusion gl) && - eq_named_context_val (hypotheses subgoal) (hypotheses gl) - - -let weak_progress gls ptree = - (List.length gls.it <> 1) || - (not (same_goal (List.hd gls.it) ptree.it)) - -let progress gls ptree = - (progress_evar_map ptree.sigma gls.sigma) || - (weak_progress gls ptree) - +(* PROGRESS tac ptree applies tac to the goal ptree and fails if tac leaves +the goal unchanged *) +let tclWEAK_PROGRESS tac ptree = + let rslt = tac ptree in + if Goal.V82.weak_progress rslt ptree then rslt + else errorlabstrm "Refiner.WEAK_PROGRESS" (str"Failed to progress.") (* PROGRESS tac ptree applies tac to the goal ptree and fails if tac leaves the goal unchanged *) let tclPROGRESS tac ptree = let rslt = tac ptree in - if progress (fst rslt) ptree then rslt + if Goal.V82.progress rslt ptree then rslt else errorlabstrm "Refiner.PROGRESS" (str"Failed to progress.") -(* weak_PROGRESS tac ptree applies tac to the goal ptree and fails - if tac leaves the goal unchanged, possibly modifying sigma *) -let tclWEAK_PROGRESS tac ptree = - let rslt = tac ptree in - if weak_progress (fst rslt) ptree then rslt - else errorlabstrm "Refiner.tclWEAK_PROGRESS" (str"Failed to progress.") - - (* Same as tclWEAK_PROGRESS but fails also if tactics generates several goals, one of them being identical to the original goal *) let tclNOTSAMEGOAL (tac : tactic) goal = + let same_goal gls1 evd2 gl2 = + Goal.V82.same_goal gls1.sigma gls1.it evd2 gl2 + in let rslt = tac goal in - let gls = (fst rslt).it in - if List.exists (same_goal goal.it) gls + let {it=gls;sigma=sigma} = rslt in + if List.exists (same_goal goal sigma) gls then errorlabstrm "Refiner.tclNOTSAMEGOAL" (str"Tactic generated a subgoal identical to the original goal.") else rslt @@ -525,9 +288,9 @@ let tclORELSE_THEN t1 t2then t2else gls = with e -> catch_failerror e; None with | None -> t2else gls - | Some (sgl,v) -> + | Some sgl -> let (sigr,gl) = unpackage sgl in - finish_tac (then_tac t2then (sigr,gl,v)) + finish_tac (then_tac t2then (sigr,gl)) (* TRY f tries to apply f, and if it fails, leave the goal unchanged *) let tclTRY f = (tclORELSE0 f tclIDTAC) @@ -601,14 +364,12 @@ let rec tclREPEAT_MAIN t g = (*s Tactics handling a list of goals. *) -type validation_list = proof_tree list -> proof_tree list - -type tactic_list = (goal list sigma) -> (goal list sigma) * validation_list +type tactic_list = (goal list sigma) -> (goal list sigma) (* Functions working on goal list for correct backtracking in Prolog *) let tclFIRSTLIST = tclFIRST -let tclIDTAC_list gls = (gls, fun x -> x) +let tclIDTAC_list gls = gls (* first_goal : goal list sigma -> goal sigma *) @@ -628,286 +389,20 @@ let apply_tac_list tac glls = let (sigr,lg) = unpackage glls in match lg with | (g1::rest) -> - let (gl,p) = apply_sig_tac sigr tac g1 in - let n = List.length gl in - (repackage sigr (gl@rest), - fun pfl -> let (pfg,pfrest) = list_chop n pfl in (p pfg)::pfrest) + let gl = apply_sig_tac sigr tac g1 in + repackage sigr (gl@rest) | _ -> error "apply_tac_list" let then_tactic_list tacl1 tacl2 glls = - let (glls1,pl1) = tacl1 glls in - let (glls2,pl2) = tacl2 glls1 in - (glls2, compose pl1 pl2) + let glls1 = tacl1 glls in + let glls2 = tacl2 glls1 in + glls2 (* Transform a tactic_list into a tactic *) let tactic_list_tactic tac gls = - let (glres,vl) = tac (goal_goal_list gls) in - (glres, compose idtac_valid vl) - - - -(* The type of proof-trees state and a few utilities - A proof-tree state is built from a proof-tree, a set of global - constraints, and a stack which allows to navigate inside the - proof-tree remembering how to rebuild the global proof-tree - possibly after modification of one of the focused children proof-tree. - The number in the stack corresponds to - either the selected subtree and the validation is a function from a - proof-tree list consisting only of one proof-tree to the global - proof-tree - or -1 when the move is done behind a registered tactic in which - case the validation corresponds to a constant function giving back - the original proof-tree. *) - -type pftreestate = { - tpf : proof_tree ; - tpfsigma : evar_map; - tstack : (int * validation) list } - -let proof_of_pftreestate pts = pts.tpf -let is_top_pftreestate pts = pts.tstack = [] -let cursor_of_pftreestate pts = List.map fst pts.tstack -let evc_of_pftreestate pts = pts.tpfsigma - -let top_goal_of_pftreestate pts = - { it = goal_of_proof pts.tpf; sigma = pts.tpfsigma } - -let nth_goal_of_pftreestate n pts = - let goals = fst (frontier pts.tpf) in - try {it = List.nth goals (n-1); sigma = pts.tpfsigma } - with Invalid_argument _ | Failure _ -> non_existent_goal n - -let traverse n pts = match n with - | 0 -> (* go to the parent *) - (match pts.tstack with - | [] -> error "traverse: no ancestors" - | (_,v)::tl -> - let pf = v [pts.tpf] in - let pf = norm_evar_proof pts.tpfsigma pf in - { tpf = pf; - tstack = tl; - tpfsigma = pts.tpfsigma }) - | -1 -> (* go to the hidden tactic-proof, if any, otherwise fail *) - (match pts.tpf.ref with - | Some (Nested (_,spf),_) -> - let v = (fun pfl -> pts.tpf) in - { tpf = spf; - tstack = (-1,v)::pts.tstack; - tpfsigma = pts.tpfsigma } - | _ -> error "traverse: not a tactic-node") - | n -> (* when n>0, go to the nth child *) - let (npf,v) = descend n pts.tpf in - { tpf = npf; - tpfsigma = pts.tpfsigma; - tstack = (n,v):: pts.tstack } - -let change_constraints_pftreestate newgc pts = { pts with tpfsigma = newgc } - -let app_tac sigr tac p = - let (gll,v) = tac {it=p.goal;sigma= !sigr} in - sigr := gll.sigma; - v (List.map leaf gll.it) - -(* modify proof state at current position *) - -let map_pftreestate f pts = - let sigr = ref pts.tpfsigma in - let tpf' = f sigr pts.tpf in - let tpf'' = - if !sigr == pts.tpfsigma then tpf' else norm_evar_proof !sigr tpf' in - { tpf = tpf''; - tpfsigma = !sigr; - tstack = pts.tstack } - -(* solve the nth subgoal with tactic tac *) - -let solve_nth_pftreestate n tac = - map_pftreestate - (fun sigr pt -> frontier_map (app_tac sigr tac) n pt) - -let solve_pftreestate = solve_nth_pftreestate 1 - -(* This function implements a poor man's undo at the current goal. - This is a gross approximation as it does not attempt to clean correctly - the global constraints given in tpfsigma. *) - -let weak_undo_pftreestate pts = - let pf = leaf pts.tpf.goal in - { tpf = pf; - tpfsigma = pts.tpfsigma; - tstack = pts.tstack } - -(* Gives a new proof (a leaf) of a goal gl *) -let mk_pftreestate g = - { tpf = leaf g; - tstack = []; - tpfsigma = Evd.empty } - -(* Extracts a constr from a proof-tree state ; raises an error if the - proof is not complete or the state does not correspond to the head - of the proof-tree *) - -let extract_open_pftreestate pts = - extract_open_proof pts.tpfsigma pts.tpf - -let extract_pftreestate pts = - if pts.tstack <> [] then - errorlabstrm "extract_pftreestate" (str"Proof blocks need to be closed"); - let pfterm,subgoals = extract_open_pftreestate pts in - let exl = Evarutil.non_instantiated pts.tpfsigma in - if subgoals <> [] or exl <> [] then - errorlabstrm "extract_proof" - (if subgoals <> [] then - str "Attempt to save an incomplete proof" - else - str "Attempt to save a proof with existential variables still non-instantiated"); - let env = Global.env_of_context pts.tpf.goal.evar_hyps in - nf_betaiota_preserving_vm_cast env pts.tpfsigma pfterm - (* strong whd_betaiotaevar env pts.tpfsigma pfterm *) - (*** - local_strong (Evarutil.whd_ise (ts_it pts.tpfsigma)) pfterm - ***) -(* Focus on the first leaf proof in a proof-tree state *) - -let rec first_unproven pts = - let pf = (proof_of_pftreestate pts) in - if is_complete_proof pf then - errorlabstrm "first_unproven" (str"No unproven subgoals"); - if is_leaf_proof pf then - pts - else - let childnum = - list_try_find_i - (fun n pf -> - if not(is_complete_proof pf) then n else failwith "caught") - 1 (children_of_proof pf) - in - first_unproven (traverse childnum pts) - -(* Focus on the last leaf proof in a proof-tree state *) - -let rec last_unproven pts = - let pf = proof_of_pftreestate pts in - if is_complete_proof pf then - errorlabstrm "last_unproven" (str"No unproven subgoals"); - if is_leaf_proof pf then - pts - else - let children = (children_of_proof pf) in - let nchilds = List.length children in - let childnum = - list_try_find_i - (fun n pf -> - if not(is_complete_proof pf) then n else failwith "caught") - 1 (List.rev children) - in - last_unproven (traverse (nchilds-childnum+1) pts) - -let rec nth_unproven n pts = - let pf = proof_of_pftreestate pts in - if is_complete_proof pf then - errorlabstrm "nth_unproven" (str"No unproven subgoals"); - if is_leaf_proof pf then - if n = 1 then - pts - else - errorlabstrm "nth_unproven" (str"Not enough unproven subgoals") - else - let children = children_of_proof pf in - let rec process i k = function - | [] -> - errorlabstrm "nth_unproven" (str"Not enough unproven subgoals") - | pf1::rest -> - let k1 = nb_unsolved_goals pf1 in - if k1 < k then - process (i+1) (k-k1) rest - else - nth_unproven k (traverse i pts) - in - process 1 n children - -let rec node_prev_unproven loc pts = - let pf = proof_of_pftreestate pts in - match cursor_of_pftreestate pts with - | [] -> last_unproven pts - | n::l -> - if is_complete_proof pf or loc = 1 then - node_prev_unproven n (traverse 0 pts) - else - let child = List.nth (children_of_proof pf) (loc - 2) in - if is_complete_proof child then - node_prev_unproven (loc - 1) pts - else - first_unproven (traverse (loc - 1) pts) - -let rec node_next_unproven loc pts = - let pf = proof_of_pftreestate pts in - match cursor_of_pftreestate pts with - | [] -> first_unproven pts - | n::l -> - if is_complete_proof pf || - loc = (List.length (children_of_proof pf)) then - node_next_unproven n (traverse 0 pts) - else if is_complete_proof (List.nth (children_of_proof pf) loc) then - node_next_unproven (loc + 1) pts - else - last_unproven(traverse (loc + 1) pts) - -let next_unproven pts = - let pf = proof_of_pftreestate pts in - if is_leaf_proof pf then - match cursor_of_pftreestate pts with - | [] -> error "next_unproven" - | n::_ -> node_next_unproven n (traverse 0 pts) - else - node_next_unproven (List.length (children_of_proof pf)) pts - -let prev_unproven pts = - let pf = proof_of_pftreestate pts in - if is_leaf_proof pf then - match cursor_of_pftreestate pts with - | [] -> error "prev_unproven" - | n::_ -> node_prev_unproven n (traverse 0 pts) - else - node_prev_unproven 1 pts - -let rec top_of_tree pts = - if is_top_pftreestate pts then pts else top_of_tree(traverse 0 pts) - -(* FIXME: cette fonction n'est (as of October 2007) appelée nulle part *) -let change_rule f pts = - let mark_top _ pt = - match pt.ref with - Some (oldrule,l) -> - {pt with ref=Some (f oldrule,l)} - | _ -> invalid_arg "change_rule" in - map_pftreestate mark_top pts - -let match_rule p pts = - match (proof_of_pftreestate pts).ref with - Some (r,_) -> p r - | None -> false - -let rec up_until_matching_rule p pts = - if is_top_pftreestate pts then - raise Not_found - else - let one_up = traverse 0 pts in - if match_rule p one_up then - pts - else - up_until_matching_rule p one_up - -let rec up_to_matching_rule p pts = - if match_rule p pts then - pts - else - if is_top_pftreestate pts then - raise Not_found - else - let one_up = traverse 0 pts in - up_to_matching_rule p one_up + let glres = tac (goal_goal_list gls) in + glres (* Change evars *) let tclEVARS sigma gls = tclIDTAC {gls with sigma=sigma} @@ -918,28 +413,8 @@ let pp_info = ref (fun _ _ _ -> assert false) let set_info_printer f = pp_info := f let tclINFO (tac : tactic) gls = - let (sgl,v) as res = tac gls in - begin try - let pf = v (List.map leaf (sig_it sgl)) in - let sign = named_context_of_val (sig_it gls).evar_hyps in - msgnl (hov 0 (str" == " ++ - !pp_info (project gls) sign pf)) - with e when catchable_exception e -> - msgnl (hov 0 (str "Info failed to apply validation")) - end; - res - -let pp_proof = ref (fun _ _ _ -> assert false) -let set_proof_printer f = pp_proof := f - -let print_pftreestate {tpf = pf; tpfsigma = sigma; tstack = stack } = - (if stack = [] - then str "Rooted proof tree is:" - else (str "Proof tree at occurrence [" ++ - prlist_with_sep (fun () -> str ";") (fun (n,_) -> int n) - (List.rev stack) ++ str "] is:")) ++ fnl() ++ - !pp_proof sigma (Global.named_context()) pf ++ - Evd.pr_evar_map sigma + msgnl (hov 0 (str "Warning: info is currently not working")); + tac gls (* Check that holes in arguments have been resolved *) @@ -962,5 +437,5 @@ let tclWITHHOLES accept_unresolved_holes tac sigma c gl = else let res = tclTHEN (tclEVARS sigma) (tac c) gl in if not accept_unresolved_holes then - check_evars (pf_env gl) (fst res).sigma sigma gl; + check_evars (pf_env gl) (res).sigma sigma gl; res diff --git a/proofs/refiner.mli b/proofs/refiner.mli index e853c12b7c..77f2e48a7d 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -12,9 +12,9 @@ open Term open Sign open Evd -open Proof_trees open Proof_type open Tacexpr +open Logic (*i*) (* The refiner (handles primitive rules and high-level tactics). *) @@ -28,14 +28,14 @@ val pf_hyps : goal sigma -> named_context val unpackage : 'a sigma -> evar_map ref * 'a val repackage : evar_map ref -> 'a -> 'a sigma val apply_sig_tac : - evar_map ref -> (goal sigma -> (goal list) sigma * validation) -> goal -> (goal list) * validation - -type transformation_tactic = proof_tree -> (goal list * validation) + evar_map ref -> (goal sigma -> goal list sigma) -> goal -> goal list (*s Hiding the implementation of tactics. *) (* [abstract_tactic tac] hides the (partial) proof produced by [tac] under a single proof node. The boolean tells if the default tactic is used. *) +(* spiwack: currently here for compatibility, abstract_operation + is a second projection *) val abstract_operation : compound_rule -> tactic -> tactic val abstract_tactic : ?dflt:bool -> atomic_tactic_expr -> tactic -> tactic val abstract_tactic_expr : ?dflt:bool -> tactic_expr -> tactic -> tactic @@ -43,22 +43,6 @@ val abstract_extended_tactic : ?dflt:bool -> string -> typed_generic_argument list -> tactic -> tactic val refiner : rule -> tactic -val frontier : transformation_tactic -val list_pf : proof_tree -> goal list -val unTAC : tactic -> goal sigma -> proof_tree sigma - - -(* Install a hook frontier_map and frontier_mapi call on the new node they create *) -val set_solve_hook : (Proof_type.proof_tree -> unit) -> unit -(* [frontier_map f n p] applies f on the n-th open subgoal of p and - rebuilds proof-tree. - n=1 for first goal, n negative counts from the right *) -val frontier_map : - (proof_tree -> proof_tree) -> int -> proof_tree -> proof_tree - -(* [frontier_mapi f p] applies (f i) on the i-th open subgoal of p. *) -val frontier_mapi : - (int -> proof_tree -> proof_tree) -> proof_tree -> proof_tree (*s Tacticals. *) @@ -153,8 +137,8 @@ val tclAT_LEAST_ONCE : tactic -> tactic val tclFAIL : int -> Pp.std_ppcmds -> tactic val tclFAIL_lazy : int -> Pp.std_ppcmds Lazy.t -> tactic val tclDO : int -> tactic -> tactic -val tclPROGRESS : tactic -> tactic val tclWEAK_PROGRESS : tactic -> tactic +val tclPROGRESS : tactic -> tactic val tclNOTSAMEGOAL : tactic -> tactic val tclINFO : tactic -> tactic @@ -173,9 +157,7 @@ val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic (*s Tactics handling a list of goals. *) -type validation_list = proof_tree list -> proof_tree list - -type tactic_list = (goal list sigma) -> (goal list sigma) * validation_list +type tactic_list = goal list sigma -> goal list sigma val tclFIRSTLIST : tactic_list list -> tactic_list val tclIDTAC_list : tactic_list @@ -191,57 +173,4 @@ val goal_goal_list : 'a sigma -> 'a list sigma extension of the sigma of the goal *) val tclWITHHOLES : bool -> ('a -> tactic) -> evar_map -> 'a -> tactic -(*s Functions for handling the state of the proof editor. *) - -type pftreestate - -val proof_of_pftreestate : pftreestate -> proof_tree -val cursor_of_pftreestate : pftreestate -> int list -val is_top_pftreestate : pftreestate -> bool -val match_rule : (rule -> bool) -> pftreestate -> bool -val evc_of_pftreestate : pftreestate -> evar_map -val top_goal_of_pftreestate : pftreestate -> goal sigma -val nth_goal_of_pftreestate : int -> pftreestate -> goal sigma - -val traverse : int -> pftreestate -> pftreestate -val map_pftreestate : - (evar_map ref -> proof_tree -> proof_tree) -> pftreestate -> pftreestate -val solve_nth_pftreestate : int -> tactic -> pftreestate -> pftreestate -val solve_pftreestate : tactic -> pftreestate -> pftreestate - -(* a weak version of logical undoing, that is really correct only *) -(* if there are no existential variables. *) -val weak_undo_pftreestate : pftreestate -> pftreestate - -val mk_pftreestate : goal -> pftreestate -val extract_open_proof : evar_map -> proof_tree -> constr * (int * types) list -val extract_open_pftreestate : pftreestate -> constr * Termops.meta_type_map -val extract_pftreestate : pftreestate -> constr -val first_unproven : pftreestate -> pftreestate -val last_unproven : pftreestate -> pftreestate -val nth_unproven : int -> pftreestate -> pftreestate -val node_prev_unproven : int -> pftreestate -> pftreestate -val node_next_unproven : int -> pftreestate -> pftreestate -val next_unproven : pftreestate -> pftreestate -val prev_unproven : pftreestate -> pftreestate -val top_of_tree : pftreestate -> pftreestate -val match_rule : (rule -> bool) -> pftreestate -> bool -val up_until_matching_rule : (rule -> bool) -> - pftreestate -> pftreestate -val up_to_matching_rule : (rule -> bool) -> - pftreestate -> pftreestate -val change_rule : (rule -> rule) -> pftreestate -> pftreestate -val change_constraints_pftreestate - : evar_map -> pftreestate -> pftreestate - - (*s Pretty-printers. *) - -(*i*) -open Pp -(*i*) -val set_info_printer : - (evar_map -> named_context -> proof_tree -> Pp.std_ppcmds) -> unit -val set_proof_printer : - (evar_map -> named_context -> proof_tree -> Pp.std_ppcmds) -> unit -val print_pftreestate : pftreestate -> Pp.std_ppcmds diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 9e35abfc89..6dbdf17cb8 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -21,7 +21,6 @@ open Evd open Typing open Redexpr open Tacred -open Proof_trees open Proof_type open Logic open Refiner @@ -34,7 +33,6 @@ let re_sig it gc = { it = it; sigma = gc } (**************************************************************) type 'a sigma = 'a Evd.sigma;; -type validation = Proof_type.validation;; type tactic = Proof_type.tactic;; let unpackage = Refiner.unpackage @@ -46,7 +44,7 @@ let project = Refiner.project let pf_env = Refiner.pf_env let pf_hyps = Refiner.pf_hyps -let pf_concl gls = (sig_it gls).evar_concl +let pf_concl gls = Goal.V82.concl (project gls) (sig_it gls) let pf_hyps_types gls = let sign = Environ.named_context (pf_env gls) in List.map (fun (id,_,x) -> (id, x)) sign @@ -123,11 +121,11 @@ let pf_matches = pf_apply Matching.matches_conv (* Tactics handling a list of goals *) (************************************) -type transformation_tactic = proof_tree -> (goal list * validation) +type transformation_tactic = proof_tree -> goal list type validation_list = proof_tree list -> proof_tree list -type tactic_list = (goal list sigma) -> (goal list sigma) * validation_list +type tactic_list = Refiner.tactic_list let first_goal = first_goal let goal_goal_list = goal_goal_list @@ -138,37 +136,6 @@ let tclFIRSTLIST = tclFIRSTLIST let tclIDTAC_list = tclIDTAC_list -(********************************************************) -(* Functions for handling the state of the proof editor *) -(********************************************************) - -type pftreestate = Refiner.pftreestate - -let proof_of_pftreestate = proof_of_pftreestate -let cursor_of_pftreestate = cursor_of_pftreestate -let is_top_pftreestate = is_top_pftreestate -let evc_of_pftreestate = evc_of_pftreestate -let top_goal_of_pftreestate = top_goal_of_pftreestate -let nth_goal_of_pftreestate = nth_goal_of_pftreestate -let traverse = traverse -let solve_nth_pftreestate = solve_nth_pftreestate -let solve_pftreestate = solve_pftreestate -let weak_undo_pftreestate = weak_undo_pftreestate -let mk_pftreestate = mk_pftreestate -let extract_pftreestate = extract_pftreestate -let extract_open_pftreestate = extract_open_pftreestate -let first_unproven = first_unproven -let last_unproven = last_unproven -let nth_unproven = nth_unproven -let node_prev_unproven = node_prev_unproven -let node_next_unproven = node_next_unproven -let next_unproven = next_unproven -let prev_unproven = prev_unproven -let top_of_tree = top_of_tree -let frontier = frontier -let change_constraints_pftreestate = change_constraints_pftreestate - - (********************************************) (* Definition of the most primitive tactics *) (********************************************) @@ -243,10 +210,18 @@ let rec pr_list f = function | [] -> mt () | a::l1 -> (f a) ++ pr_list f l1 +let db_pr_goal sigma g = + let env = Goal.V82.env sigma g in + let penv = print_named_context env in + let pc = print_constr_env env (Goal.V82.concl sigma g) in + str" " ++ hv 0 (penv ++ fnl () ++ + str "============================" ++ fnl () ++ + str" " ++ pc) ++ fnl () + let pr_gls gls = - hov 0 (pr_evar_map (sig_sig gls) ++ fnl () ++ db_pr_goal (sig_it gls)) + hov 0 (pr_evar_map (sig_sig gls) ++ fnl () ++ db_pr_goal (project gls) (sig_it gls)) let pr_glls glls = hov 0 (pr_evar_map (sig_sig glls) ++ fnl () ++ - prlist_with_sep pr_fnl db_pr_goal (sig_it glls)) + prlist_with_sep pr_fnl (db_pr_goal (project glls)) (sig_it glls)) diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index a808ca4190..f4bb1d9220 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -15,7 +15,6 @@ open Sign open Environ open Evd open Reduction -open Proof_trees open Proof_type open Refiner open Redexpr @@ -27,7 +26,6 @@ open Pattern (* Operations for handling terms under a local typing context. *) type 'a sigma = 'a Evd.sigma;; -type validation = Proof_type.validation;; type tactic = Proof_type.tactic;; val sig_it : 'a sigma -> 'a @@ -38,7 +36,7 @@ val re_sig : 'a -> evar_map -> 'a sigma val unpackage : 'a sigma -> evar_map ref * 'a val repackage : evar_map ref -> 'a -> 'a sigma val apply_sig_tac : - evar_map ref -> (goal sigma -> (goal list) sigma * validation) -> goal -> (goal list) * validation + evar_map ref -> (goal sigma -> (goal list) sigma) -> goal -> (goal list) val pf_concl : goal sigma -> types val pf_env : goal sigma -> env @@ -90,38 +88,6 @@ val pf_conv_x_leq : goal sigma -> constr -> constr -> bool val pf_matches : goal sigma -> constr_pattern -> constr -> patvar_map val pf_is_matching : goal sigma -> constr_pattern -> constr -> bool -type transformation_tactic = proof_tree -> (goal list * validation) - -val frontier : transformation_tactic - - -(*s Functions for handling the state of the proof editor. *) - -type pftreestate = Refiner.pftreestate - -val proof_of_pftreestate : pftreestate -> proof_tree -val cursor_of_pftreestate : pftreestate -> int list -val is_top_pftreestate : pftreestate -> bool -val evc_of_pftreestate : pftreestate -> evar_map -val top_goal_of_pftreestate : pftreestate -> goal sigma -val nth_goal_of_pftreestate : int -> pftreestate -> goal sigma -val traverse : int -> pftreestate -> pftreestate -val weak_undo_pftreestate : pftreestate -> pftreestate -val solve_nth_pftreestate : int -> tactic -> pftreestate -> pftreestate -val solve_pftreestate : tactic -> pftreestate -> pftreestate -val mk_pftreestate : goal -> pftreestate -val extract_open_pftreestate : pftreestate -> constr * Termops.meta_type_map -val extract_pftreestate : pftreestate -> constr -val first_unproven : pftreestate -> pftreestate -val last_unproven : pftreestate -> pftreestate -val nth_unproven : int -> pftreestate -> pftreestate -val node_prev_unproven : int -> pftreestate -> pftreestate -val node_next_unproven : int -> pftreestate -> pftreestate -val next_unproven : pftreestate -> pftreestate -val prev_unproven : pftreestate -> pftreestate -val top_of_tree : pftreestate -> pftreestate -val change_constraints_pftreestate : - evar_map -> pftreestate -> pftreestate (*s The most primitive tactics. *) @@ -159,7 +125,7 @@ val rename_hyp : (identifier*identifier) list -> tactic type validation_list = proof_tree list -> proof_tree list -type tactic_list = (goal list sigma) -> (goal list sigma) * validation_list +type tactic_list = Refiner.tactic_list val first_goal : 'a list sigma -> 'a sigma val goal_goal_list : 'a sigma -> 'a list sigma diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml index ea8ab5b625..f6b2ce4525 100644 --- a/proofs/tactic_debug.ml +++ b/proofs/tactic_debug.ml @@ -36,8 +36,18 @@ let explain_logic_error = ref (fun e -> mt()) let explain_logic_error_no_anomaly = ref (fun e -> mt()) (* Prints the goal *) + +let db_pr_goal g = + let env = Refiner.pf_env g in + let penv = print_named_context env in + let pc = print_constr_env env (Goal.V82.concl (Refiner.project g) (Refiner.sig_it g)) in + str" " ++ hv 0 (penv ++ fnl () ++ + str "============================" ++ fnl () ++ + str" " ++ pc) ++ fnl () + let db_pr_goal g = - msgnl (str "Goal:" ++ fnl () ++ Proof_trees.db_pr_goal (Refiner.sig_it g)) + msgnl (str "Goal:" ++ fnl () ++ db_pr_goal g) + (* Prints the commands *) let help () = diff --git a/tactics/auto.ml b/tactics/auto.ml index 06c4fab6e1..d2bb1a06fc 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -280,9 +280,7 @@ let try_head_pattern c = try head_pattern_bound c with BoundPattern -> error "Bound head variable." -let dummy_goal = - {it = make_evar empty_named_context_val mkProp; - sigma = empty} +let dummy_goal = Goal.V82.dummy_goal let make_exact_entry sigma pri (c,cty) = let cty = strip_outer_cast cty in @@ -700,7 +698,8 @@ let print_hint_term cl = ppnl (pr_hint_term cl) (* print all hints that apply to the concl of the current goal *) let print_applicable_hint () = let pts = get_pftreestate () in - let gl = nth_goal_of_pftreestate 1 pts in + let glss = Proof.V82.subgoals pts in + let gl = { Evd.it = List.hd glss.Evd.it; sigma = glss.Evd.sigma } in print_hint_term (pf_concl gl) (* displays the whole hint database db *) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index b0645744b4..a0dea0292e 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -132,16 +132,16 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic = let to_be_cleared = ref false in fun dir cstr tac gl -> let last_hyp_id = - match (Environ.named_context_of_val gl.Evd.it.Evd.evar_hyps) with + match Tacmach.pf_hyps gl with (last_hyp_id,_,_)::_ -> last_hyp_id | _ -> (* even the hypothesis id is missing *) error ("No such hypothesis: " ^ (string_of_id !id) ^".") in let gl' = general_rewrite_in dir all_occurrences ~tac:(tac, conds) false !id cstr false gl in - let gls = (fst gl').Evd.it in + let gls = gl'.Evd.it in match gls with g::_ -> - (match Environ.named_context_of_val g.Evd.evar_hyps with + (match Environ.named_context_of_val (Goal.V82.hyps gl'.Evd.sigma g) with (lastid,_,_)::_ -> if last_hyp_id <> lastid then begin diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4 index 4c58edf595..e0e7aae2fe 100644 --- a/tactics/class_tactics.ml4 +++ b/tactics/class_tactics.ml4 @@ -20,7 +20,6 @@ open Termops open Sign open Reduction open Proof_type -open Proof_trees open Declarations open Tacticals open Tacmach @@ -54,17 +53,6 @@ let is_dependent ev evm = else dep || occur_evar ev evi.evar_concl) evm false -let valid goals p res_sigma l = - let evm = - List.fold_left2 - (fun sigma (ev, evi) prf -> - let cstr, obls = Refiner.extract_open_proof !res_sigma prf in - if not (Evd.is_defined sigma ev) then - Evd.define ev cstr sigma - else sigma) - !res_sigma goals l - in raise (Found evm) - let evar_filter evi = let hyps' = evar_filtered_context evi in { evi with @@ -78,7 +66,7 @@ let evars_to_goals p evm = if evi.evar_body = Evar_empty then let evi', goal = p evm ev evi in if goal then - ((ev, evi') :: gls, Evd.add evm' ev evi') + ((ev,Goal.V82.build ev) :: gls, Evd.add evm' ev evi') else (gls, Evd.add evm' ev evi') else (gls, Evd.add evm' ev evi)) evm ([], Evd.empty) @@ -223,29 +211,17 @@ let rec catchable = function | Stdpp.Exc_located (_, e) -> catchable e | e -> Logic.catchable_exception e -let is_dep gl gls = - let evs = Evarutil.evars_of_term gl.evar_concl in - if evs = Intset.empty then false - else - List.fold_left - (fun b gl -> - if b then b - else - let evs' = Evarutil.evars_of_term gl.evar_concl in - intersects evs evs') - false gls - let is_ground gl = Evarutil.is_ground_term (project gl) (pf_concl gl) let nb_empty_evars s = Evd.fold (fun ev evi acc -> if evi.evar_body = Evar_empty then succ acc else acc) s 0 -let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) +let pr_ev evs ev = Printer.pr_constr_env (Goal.V82.env evs ev) (Evarutil.nf_evar evs (Goal.V82.concl evs ev)) -let typeclasses_debug = ref false +let pr_depth l = prlist_with_sep (fun () -> str ".") pr_int (List.rev l) -type validation = evar_map -> proof_tree list -> proof_tree +let typeclasses_debug = ref false let pr_depth l = prlist_with_sep (fun () -> str ".") pr_int (List.rev l) @@ -256,7 +232,7 @@ type 'ans fk = unit -> 'ans type ('a,'ans) sk = 'a -> 'ans fk -> 'ans type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans } -type auto_result = autogoal list sigma * validation +type auto_result = autogoal list sigma type atac = auto_result tac @@ -281,7 +257,7 @@ let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) = else [] let pf_filtered_hyps gls = - evar_filtered_context (sig_it gls) + Goal.V82.filtered_context gls.Evd.sigma (sig_it gls) let make_autogoal_hints only_classes ?(st=full_transparent_state) g = let sign = pf_filtered_hyps g in @@ -292,7 +268,7 @@ let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : ' { skft = fun sk fk {it = gl,hints; sigma=s} -> let res = try Some (tac {it=gl; sigma=s}) with e when catchable e -> None in match res with - | Some (gls,v) -> sk (f gls hints, fun _ -> v) fk + | Some gls -> sk (f gls hints) fk | None -> fk () } let intro_tac : atac = @@ -300,28 +276,33 @@ let intro_tac : atac = (fun {it = gls; sigma = s} info -> let gls' = List.map (fun g' -> - let env = evar_env g' in + let env = Goal.V82.env s g' in + let context = Environ.named_context_of_val (Goal.V82.hyps s g') in let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) - (true,false,false) info.only_classes None (List.hd (evar_context g')) in + (true,false,false) info.only_classes None (List.hd context) in let ldb = Hint_db.add_list hint info.hints in (g', { info with is_evar = None; hints = ldb; auto_last_tac = str"intro" })) gls in {it = gls'; sigma = s}) let normevars_tac : atac = - lift_tactic tclNORMEVAR - (fun {it = gls; sigma = s} info -> - let gls' = - List.map (fun g' -> - (g', { info with auto_last_tac = str"NORMEVAR" })) gls - in {it = gls'; sigma = s}) + { skft = fun sk fk {it = gl; sigma = s} -> + let gl', sigma' = Goal.V82.nf_evar s (fst gl) in + sk {it = [gl', snd gl]; sigma = sigma'} fk } + + (* lift_tactic tclNORMEVAR *) + (* (fun {it = gls; sigma = s} info -> *) + (* let gls' = *) + (* List.map (fun g' -> *) + (* (g', { info with auto_last_tac = str"NORMEVAR" })) gls *) + (* in {it = gls'; sigma = s}) *) let id_tac : atac = { skft = fun sk fk {it = gl; sigma = s} -> - sk ({it = [gl]; sigma = s}, fun _ pfs -> List.hd pfs) fk } + sk {it = [gl]; sigma = s} fk } (* Ordering of states is lexicographic on the number of remaining goals. *) -let compare (pri, _, _, (res, _)) (pri', _, _, (res', _)) = +let compare (pri, _, _, res) (pri', _, _, res') = let nbgoals s = List.length (sig_it s) + nb_empty_evars (sig_sig s) in @@ -344,11 +325,11 @@ let solve_unif_tac : atac = let hints_tac hints = { skft = fun sk fk {it = gl,info; sigma = s} -> - let possible_resolve ((lgls,v) as res, pri, b, pp) = + let possible_resolve (lgls as res, pri, b, pp) = (pri, pp, b, res) in let tacs = - let concl = gl.evar_concl in + let concl = Goal.V82.concl s gl in let poss = e_possible_resolve hints info.hints concl in let l = let tacgl = {it = gl; sigma = s} in @@ -358,25 +339,26 @@ let hints_tac hints = in if l = [] && !typeclasses_debug then msgnl (pr_depth info.auto_depth ++ str": no match for " ++ - Printer.pr_constr_env (Evd.evar_env gl) concl ++ + Printer.pr_constr_env (Goal.V82.env s gl) concl ++ spc () ++ int (List.length poss) ++ str" possibilities"); List.map possible_resolve l in let tacs = List.sort compare tacs in let rec aux i = function - | (_, pp, b, ({it = gls; sigma = s}, v)) :: tl -> + | (_, pp, b, {it = gls; sigma = s}) :: tl -> if !typeclasses_debug then msgnl (pr_depth (i :: info.auto_depth) ++ str": " ++ pp ++ str" on" ++ spc () ++ pr_ev s gl); let fk = (fun () -> (* if !typeclasses_debug then msgnl (str"backtracked after " ++ pp); *) aux (succ i) tl) in - let sgls = evars_to_goals (fun evm ev evi -> - if Typeclasses.is_resolvable evi && - (not info.only_classes || Typeclasses.is_class_evar evm evi) then - Typeclasses.mark_unresolvable evi, true - else evi, false) s - in + let sgls = None in + (* evars_to_goals (fun evm ev evi -> *) + (* if Typeclasses.is_resolvable evi && *) + (* (not info.only_classes || Typeclasses.is_class_evar evm evi) then *) + (* Typeclasses.mark_unresolvable evi, true *) + (* else evi, false) s *) + (* in *) let nbgls, newgls, s' = let gls' = List.map (fun g -> (None, g)) gls in match sgls with @@ -389,12 +371,12 @@ let hints_tac hints = { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp; is_evar = evar; hints = - if b && g.evar_hyps <> gl.evar_hyps + if b && Goal.V82.hyps s g <> Goal.V82.hyps s gl then make_autogoal_hints info.only_classes ~st:(Hint_db.transparent_state info.hints) {it = g; sigma = s'} else info.hints } in g, info) 1 newgls in - let glsv = {it = gls'; sigma = s'}, (fun _ pfl -> v (list_firstn nbgls pfl)) in + let glsv = {it = gls'; sigma = s'} in sk glsv fk | [] -> fk () in aux 1 tacs } @@ -423,9 +405,9 @@ let dependent only_classes evd oev concl = in not (Intset.is_empty concl_evars) let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk = - let rec aux s (acc : (autogoal list * validation) list) fk = function + let rec aux s (acc : autogoal list list) fk = function | (gl,info) :: gls -> - second.skft (fun ({it=gls';sigma=s'},v') fk' -> + second.skft (fun {it=gls';sigma=s'} fk' -> let s', needs_backtrack = if gls' = [] then match info.is_evar with @@ -433,30 +415,23 @@ let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk let s' = if Evd.is_defined s' ev then s' else - let prf = v' s' [] in - let term, _ = Refiner.extract_open_proof s' prf in - Evd.define ev term s' - in s', dependent info.only_classes s' (Some ev) gl.evar_concl - | None -> s', dependent info.only_classes s' None gl.evar_concl + s' + in s', dependent info.only_classes s' (Some ev) (Goal.V82.concl s' gl) + | None -> + s', dependent info.only_classes s' None (Goal.V82.concl s' gl) else s', true in let fk'' = if not needs_backtrack then (if !typeclasses_debug then msgnl (str"no backtrack on " ++ pr_ev s gl); fk) else fk' - in aux s' ((gls',v')::acc) fk'' gls) + in aux s' (gls'::acc) fk'' gls) fk {it = (gl,info); sigma = s} | [] -> Some (List.rev acc, s, fk) - in fun ({it = gls; sigma = s},v) fk -> + in fun {it = gls; sigma = s} fk -> let rec aux' = function | None -> fk () | Some (res, s', fk') -> - let goals' = List.concat (List.map (fun (gls,v) -> gls) res) in - let v' s' pfs' : proof_tree = - let (newpfs, rest) = List.fold_left (fun (newpfs,pfs') (gls,v) -> - let before, after = list_chop (List.length gls) pfs' in - (v s' before :: newpfs, after)) - ([], pfs') res - in assert(rest = []); v s' (List.rev newpfs) - in sk ({it = goals'; sigma = s'}, v') (fun () -> aux' (fk' ())) + let goals' = List.concat res in + sk {it = goals'; sigma = s'} (fun () -> aux' (fk' ())) in aux' (aux s [] (fun () -> None) gls) let then_tac (first : atac) (second : atac) : atac = @@ -469,7 +444,7 @@ type run_list_res = (auto_result * run_list_res fk) option let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res = (then_list t (fun x fk -> Some (x, fk))) - (gl, fun s pfs -> valid goals p (ref s) pfs) + gl (fun _ -> None) let rec fix (t : 'a tac) : 'a tac = @@ -488,10 +463,8 @@ let make_autogoals ?(only_classes=true) ?(st=full_transparent_state) gs evm' = let get_result r = match r with | None -> None - | Some ((gls, v), fk) -> - try ignore(v (sig_sig gls) []); assert(false) - with Found evm' -> Some (evm', fk) - + | Some (gls, fk) -> Some (gls.sigma,fk) + let run_on_evars ?(only_classes=true) ?(st=full_transparent_state) p evm tac = match evars_to_goals p evm with | None -> None (* This happens only because there's no evar having p *) @@ -508,8 +481,8 @@ let eauto ?(only_classes=true) ?st hints g = let gl = { it = make_autogoal ~only_classes ?st None g; sigma = project g } in match run_tac (eauto_tac hints) gl with | None -> raise Not_found - | Some ({it = goals; sigma = s}, valid) -> - {it = List.map fst goals; sigma = s}, valid s + | Some {it = goals; sigma = s} -> + {it = List.map fst goals; sigma = s} let real_eauto st hints p evd = let rec aux evd fails = @@ -531,17 +504,15 @@ let resolve_all_evars_once debug (mode, depth) p evd = let db = searchtable_map typeclasses_db in real_eauto (Hint_db.transparent_state db) [db] p evd -exception FoundTerm of constr - let resolve_one_typeclass env ?(sigma=Evd.empty) gl = - let gls = { it = Evd.make_evar (Environ.named_context_val env) gl; sigma = sigma } in + let (gl,t,sigma) = + Goal.V82.mk_goal sigma (Environ.named_context_val env) gl Store.empty in + let gls = { it = gl ; sigma = sigma } in let hints = searchtable_map typeclasses_db in - let gls', v = eauto ~st:(Hint_db.transparent_state hints) [hints] gls in - let term = v [] in + let gls' = eauto ~st:(Hint_db.transparent_state hints) [hints] gls in let evd = sig_sig gls' in - let term = fst (Refiner.extract_open_proof evd term) in - let term = Evarutil.nf_evar evd term in - evd, term + let term = Evarutil.nf_evar evd t in + evd, term let _ = Typeclasses.solve_instanciation_problem := (fun x y z -> resolve_one_typeclass x ~sigma:y z) diff --git a/tactics/decl_interp.ml b/tactics/decl_interp.ml deleted file mode 100644 index 2b583af407..0000000000 --- a/tactics/decl_interp.ml +++ /dev/null @@ -1,472 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Thesis n - | This c -> This (intern_constr globs c) - -let add_var id globs= - let l1,l2=globs.ltacvars in - {globs with ltacvars= (id::l1),(id::l2)} - -let add_name nam globs= - match nam with - Anonymous -> globs - | Name id -> add_var id globs - -let intern_hyp iconstr globs = function - Hvar (loc,(id,topt)) -> add_var id globs, - Hvar (loc,(id,Option.map (intern_constr globs) topt)) - | Hprop st -> add_name st.st_label globs, - Hprop (intern_statement iconstr globs st) - -let intern_hyps iconstr globs hyps = - snd (list_fold_map (intern_hyp iconstr) globs hyps) - -let intern_cut intern_it globs cut= - let nglobs,nstat=intern_it globs cut.cut_stat in - {cut_stat=nstat; - cut_by=intern_justification_items nglobs cut.cut_by; - cut_using=intern_justification_method nglobs cut.cut_using} - -let intern_casee globs = function - Real c -> Real (intern_constr globs c) - | Virtual cut -> Virtual - (intern_cut (intern_no_bind (intern_statement intern_constr)) globs cut) - -let intern_hyp_list args globs = - let intern_one globs (loc,(id,opttyp)) = - (add_var id globs), - (loc,(id,Option.map (intern_constr globs) opttyp)) in - list_fold_map intern_one globs args - -let intern_suffices_clause globs (hyps,c) = - let nglobs,nhyps = list_fold_map (intern_hyp intern_constr) globs hyps in - nglobs,(nhyps,intern_constr_or_thesis nglobs c) - -let intern_fundecl args body globs= - let nglobs,nargs = intern_hyp_list args globs in - nargs,intern_constr nglobs body - -let rec add_vars_of_simple_pattern globs = function - CPatAlias (loc,p,id) -> - add_vars_of_simple_pattern (add_var id globs) p -(* Stdpp.raise_with_loc loc - (UserError ("simple_pattern",str "\"as\" is not allowed here"))*) - | CPatOr (loc, _)-> - Stdpp.raise_with_loc loc - (UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here")) - | CPatDelimiters (_,_,p) -> - add_vars_of_simple_pattern globs p - | CPatCstr (_,_,pl) -> - List.fold_left add_vars_of_simple_pattern globs pl - | CPatNotation(_,_,(pl,pll)) -> - List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pll)) - | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs - | _ -> globs - -let rec intern_bare_proof_instr globs = function - Pthus i -> Pthus (intern_bare_proof_instr globs i) - | Pthen i -> Pthen (intern_bare_proof_instr globs i) - | Phence i -> Phence (intern_bare_proof_instr globs i) - | Pcut c -> Pcut - (intern_cut - (intern_no_bind (intern_statement intern_constr_or_thesis)) globs c) - | Psuffices c -> - Psuffices (intern_cut intern_suffices_clause globs c) - | Prew (s,c) -> Prew - (s,intern_cut - (intern_no_bind (intern_statement intern_constr)) globs c) - | Psuppose hyps -> Psuppose (intern_hyps intern_constr globs hyps) - | Pcase (params,pat,hyps) -> - let nglobs,nparams = intern_hyp_list params globs in - let nnglobs= add_vars_of_simple_pattern nglobs pat in - let nhyps = intern_hyps intern_constr_or_thesis nnglobs hyps in - Pcase (nparams,pat,nhyps) - | Ptake witl -> Ptake (List.map (intern_constr globs) witl) - | Pconsider (c,hyps) -> Pconsider (intern_constr globs c, - intern_hyps intern_constr globs hyps) - | Pper (et,c) -> Pper (et,intern_casee globs c) - | Pend bt -> Pend bt - | Pescape -> Pescape - | Passume hyps -> Passume (intern_hyps intern_constr globs hyps) - | Pgiven hyps -> Pgiven (intern_hyps intern_constr globs hyps) - | Plet hyps -> Plet (intern_hyps intern_constr globs hyps) - | Pclaim st -> Pclaim (intern_statement intern_constr globs st) - | Pfocus st -> Pfocus (intern_statement intern_constr globs st) - | Pdefine (id,args,body) -> - let nargs,nbody = intern_fundecl args body globs in - Pdefine (id,nargs,nbody) - | Pcast (id,typ) -> - Pcast (id,intern_constr globs typ) - -let rec intern_proof_instr globs instr= - {emph = instr.emph; - instr = intern_bare_proof_instr globs instr.instr} - -(* INTERP *) - -let interp_justification_items sigma env = - Option.map (List.map (fun c ->understand sigma env (fst c))) - -let interp_constr check_sort sigma env c = - if check_sort then - understand_type sigma env (fst c) - else - understand sigma env (fst c) - -let special_whd env = - let infos=Closure.create_clos_infos Closure.betadeltaiota env in - (fun t -> Closure.whd_val infos (Closure.inject t)) - -let _eq = Libnames.constr_of_global (Coqlib.glob_eq) - -let decompose_eq env id = - let typ = Environ.named_type id env in - let whd = special_whd env typ in - match kind_of_term whd with - App (f,args)-> - if eq_constr f _eq && (Array.length args)=3 - then args.(0) - else error "Previous step is not an equality." - | _ -> error "Previous step is not an equality." - -let get_eq_typ info env = - let typ = decompose_eq env (get_last env) in - typ - -let interp_constr_in_type typ sigma env c = - understand sigma env (fst c) ~expected_type:typ - -let interp_statement interp_it sigma env st = - {st_label=st.st_label; - st_it=interp_it sigma env st.st_it} - -let interp_constr_or_thesis check_sort sigma env = function - Thesis n -> Thesis n - | This c -> This (interp_constr check_sort sigma env c) - -let abstract_one_hyp inject h raw = - match h with - Hvar (loc,(id,None)) -> - RProd (dummy_loc,Name id, Explicit, RHole (loc,Evd.BinderType (Name id)), raw) - | Hvar (loc,(id,Some typ)) -> - RProd (dummy_loc,Name id, Explicit, fst typ, raw) - | Hprop st -> - RProd (dummy_loc,st.st_label, Explicit, inject st.st_it, raw) - -let rawconstr_of_hyps inject hyps head = - List.fold_right (abstract_one_hyp inject) hyps head - -let raw_prop = RSort (dummy_loc,RProp Null) - -let rec match_hyps blend names constr = function - [] -> [],substl names constr - | hyp::q -> - let (name,typ,body)=destProd constr in - let st= {st_label=name;st_it=substl names typ} in - let qnames= - match name with - Anonymous -> mkMeta 0 :: names - | Name id -> mkVar id :: names in - let qhyp = match hyp with - Hprop st' -> Hprop (blend st st') - | Hvar _ -> Hvar st in - let rhyps,head = match_hyps blend qnames body q in - qhyp::rhyps,head - -let interp_hyps_gen inject blend sigma env hyps head = - let constr=understand sigma env (rawconstr_of_hyps inject hyps head) in - match_hyps blend [] constr hyps - -let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma env hyps raw_prop) - -let dummy_prefix= id_of_string "__" - -let rec deanonymize ids = - function - PatVar (loc,Anonymous) -> - let (found,known) = !ids in - let new_id=Namegen.next_ident_away dummy_prefix known in - let _= ids:= (loc,new_id) :: found , new_id :: known in - PatVar (loc,Name new_id) - | PatVar (loc,Name id) as pat -> - let (found,known) = !ids in - let _= ids:= (loc,id) :: found , known in - pat - | PatCstr(loc,cstr,lpat,nam) -> - PatCstr(loc,cstr,List.map (deanonymize ids) lpat,nam) - -let rec raw_of_pat = - function - PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable" - | PatVar (loc,Name id) -> - RVar (loc,id) - | PatCstr(loc,((ind,_) as cstr),lpat,_) -> - let mind= fst (Global.lookup_inductive ind) in - let rec add_params n q = - if n<=0 then q else - add_params (pred n) (RHole(dummy_loc, - Evd.TomatchTypeParameter(ind,n))::q) in - let args = List.map raw_of_pat lpat in - raw_app(loc,RRef(dummy_loc,Libnames.ConstructRef cstr), - add_params mind.Declarations.mind_nparams args) - -let prod_one_hyp = function - (loc,(id,None)) -> - (fun raw -> - RProd (dummy_loc,Name id, Explicit, - RHole (loc,Evd.BinderType (Name id)), raw)) - | (loc,(id,Some typ)) -> - (fun raw -> - RProd (dummy_loc,Name id, Explicit, fst typ, raw)) - -let prod_one_id (loc,id) raw = - RProd (dummy_loc,Name id, Explicit, - RHole (loc,Evd.BinderType (Name id)), raw) - -let let_in_one_alias (id,pat) raw = - RLetIn (dummy_loc,Name id, raw_of_pat pat, raw) - -let rec bind_primary_aliases map pat = - match pat with - PatVar (_,_) -> map - | PatCstr(loc,_,lpat,nam) -> - let map1 = - match nam with - Anonymous -> map - | Name id -> (id,pat)::map - in - List.fold_left bind_primary_aliases map1 lpat - -let bind_secondary_aliases map subst = - List.fold_left (fun map (ids,idp) -> (ids,List.assoc idp map)::map) map subst - -let bind_aliases patvars subst patt = - let map = bind_primary_aliases [] patt in - let map1 = bind_secondary_aliases map subst in - List.rev map1 - -let interp_pattern env pat_expr = - let patvars,pats = Constrintern.intern_pattern env pat_expr in - match pats with - [] -> anomaly "empty pattern list" - | [subst,patt] -> - (patvars,bind_aliases patvars subst patt,patt) - | _ -> anomaly "undetected disjunctive pattern" - -let rec match_args dest names constr = function - [] -> [],names,substl names constr - | _::q -> - let (name,typ,body)=dest constr in - let st={st_label=name;st_it=substl names typ} in - let qnames= - match name with - Anonymous -> assert false - | Name id -> mkVar id :: names in - let args,bnames,body = match_args dest qnames body q in - st::args,bnames,body - -let rec match_aliases names constr = function - [] -> [],names,substl names constr - | _::q -> - let (name,c,typ,body)=destLetIn constr in - let st={st_label=name;st_it=(substl names c,substl names typ)} in - let qnames= - match name with - Anonymous -> assert false - | Name id -> mkVar id :: names in - let args,bnames,body = match_aliases qnames body q in - st::args,bnames,body - -let detype_ground c = Detyping.detype false [] [] c - -let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = - let et,pinfo = - match info.pm_stack with - Per(et,pi,_,_)::_ -> et,pi - | _ -> error "No proof per cases/induction/inversion in progress." in - let mib,oib=Global.lookup_inductive pinfo.per_ind in - let num_params = pinfo.per_nparams in - let _ = - let expected = mib.Declarations.mind_nparams - num_params in - if List.length params <> expected then - errorlabstrm "suppose it is" - (str "Wrong number of extra arguments: " ++ - (if expected = 0 then str "none" else int expected) ++ spc () ++ - str "expected.") in - let app_ind = - let rind = RRef (dummy_loc,Libnames.IndRef pinfo.per_ind) in - let rparams = List.map detype_ground pinfo.per_params in - let rparams_rec = - List.map - (fun (loc,(id,_)) -> - RVar (loc,id)) params in - let dum_args= - list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark (Evd.Define false))) - oib.Declarations.mind_nrealargs in - raw_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in - let pat_vars,aliases,patt = interp_pattern env pat in - let inject = function - Thesis (Plain) -> Rawterm.RSort(dummy_loc,RProp Null) - | Thesis (For rec_occ) -> - if not (List.mem rec_occ pat_vars) then - errorlabstrm "suppose it is" - (str "Variable " ++ Nameops.pr_id rec_occ ++ - str " does not occur in pattern."); - Rawterm.RSort(dummy_loc,RProp Null) - | This (c,_) -> c in - let term1 = rawconstr_of_hyps inject hyps raw_prop in - let loc_ids,npatt = - let rids=ref ([],pat_vars) in - let npatt= deanonymize rids patt in - List.rev (fst !rids),npatt in - let term2 = - RLetIn(dummy_loc,Anonymous, - RCast(dummy_loc,raw_of_pat npatt, - CastConv (DEFAULTcast,app_ind)),term1) in - let term3=List.fold_right let_in_one_alias aliases term2 in - let term4=List.fold_right prod_one_id loc_ids term3 in - let term5=List.fold_right prod_one_hyp params term4 in - let constr = understand sigma env term5 in - let tparams,nam4,rest4 = match_args destProd [] constr params in - let tpatvars,nam3,rest3 = match_args destProd nam4 rest4 loc_ids in - let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in - let (_,pat_pat,pat_typ,rest1) = destLetIn rest2 in - let blend st st' = - match st'.st_it with - Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label} - | This _ -> {st_it = This st.st_it;st_label=st.st_label} in - let thyps = fst (match_hyps blend nam2 (Termops.pop rest1) hyps) in - tparams,{pat_vars=tpatvars; - pat_aliases=taliases; - pat_constr=pat_pat; - pat_typ=pat_typ; - pat_pat=patt; - pat_expr=pat},thyps - -let interp_cut interp_it sigma env cut= - let nenv,nstat = interp_it sigma env cut.cut_stat in - {cut with - cut_stat=nstat; - cut_by=interp_justification_items sigma nenv cut.cut_by} - -let interp_no_bind interp_it sigma env x = - env,interp_it sigma env x - -let interp_suffices_clause sigma env (hyps,cot)= - let (locvars,_) as res = - match cot with - This (c,_) -> - let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) sigma env hyps c in - nhyps,This nc - | Thesis Plain as th -> interp_hyps sigma env hyps,th - | Thesis (For n) -> error "\"thesis for\" is not applicable here." in - let push_one hyp env0 = - match hyp with - (Hprop st | Hvar st) -> - match st.st_label with - Name id -> Environ.push_named (id,None,st.st_it) env0 - | _ -> env in - let nenv = List.fold_right push_one locvars env in - nenv,res - -let interp_casee sigma env = function - Real c -> Real (understand sigma env (fst c)) - | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut) - -let abstract_one_arg = function - (loc,(id,None)) -> - (fun raw -> - RLambda (dummy_loc,Name id, Explicit, - RHole (loc,Evd.BinderType (Name id)), raw)) - | (loc,(id,Some typ)) -> - (fun raw -> - RLambda (dummy_loc,Name id, Explicit, fst typ, raw)) - -let rawconstr_of_fun args body = - List.fold_right abstract_one_arg args (fst body) - -let interp_fun sigma env args body = - let constr=understand sigma env (rawconstr_of_fun args body) in - match_args destLambda [] constr args - -let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = function - Pthus i -> Pthus (interp_bare_proof_instr info sigma env i) - | Pthen i -> Pthen (interp_bare_proof_instr info sigma env i) - | Phence i -> Phence (interp_bare_proof_instr info sigma env i) - | Pcut c -> Pcut (interp_cut - (interp_no_bind (interp_statement - (interp_constr_or_thesis true))) - sigma env c) - | Psuffices c -> - Psuffices (interp_cut interp_suffices_clause sigma env c) - | Prew (s,c) -> Prew (s,interp_cut - (interp_no_bind (interp_statement - (interp_constr_in_type (get_eq_typ info env)))) - sigma env c) - - | Psuppose hyps -> Psuppose (interp_hyps sigma env hyps) - | Pcase (params,pat,hyps) -> - let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in - Pcase (tparams,tpat,thyps) - | Ptake witl -> - Ptake (List.map (fun c -> understand sigma env (fst c)) witl) - | Pconsider (c,hyps) -> Pconsider (interp_constr false sigma env c, - interp_hyps sigma env hyps) - | Pper (et,c) -> Pper (et,interp_casee sigma env c) - | Pend bt -> Pend bt - | Pescape -> Pescape - | Passume hyps -> Passume (interp_hyps sigma env hyps) - | Pgiven hyps -> Pgiven (interp_hyps sigma env hyps) - | Plet hyps -> Plet (interp_hyps sigma env hyps) - | Pclaim st -> Pclaim (interp_statement (interp_constr true) sigma env st) - | Pfocus st -> Pfocus (interp_statement (interp_constr true) sigma env st) - | Pdefine (id,args,body) -> - let nargs,_,nbody = interp_fun sigma env args body in - Pdefine (id,nargs,nbody) - | Pcast (id,typ) -> - Pcast(id,interp_constr true sigma env typ) - -let rec interp_proof_instr info sigma env instr= - {emph = instr.emph; - instr = interp_bare_proof_instr info sigma env instr.instr} - - - diff --git a/tactics/decl_interp.mli b/tactics/decl_interp.mli deleted file mode 100644 index bd0859382b..0000000000 --- a/tactics/decl_interp.mli +++ /dev/null @@ -1,18 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* raw_proof_instr -> glob_proof_instr -val interp_proof_instr : Decl_mode.pm_info -> - Evd.evar_map -> Environ.env -> glob_proof_instr -> proof_instr diff --git a/tactics/decl_proof_instr.ml b/tactics/decl_proof_instr.ml deleted file mode 100644 index 9c58f06ee9..0000000000 --- a/tactics/decl_proof_instr.ml +++ /dev/null @@ -1,1518 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* (!strictness)),(fun b -> strictness:=b) - -let _ = - declare_bool_option - { optsync = true; - optname = "strict mode"; - optkey = ["Strict";"Proofs"]; - optread = get_strictness; - optwrite = set_strictness } - -let tcl_change_info_gen info_gen = - (fun gls -> - let gl =sig_it gls in - {it=[{gl with evar_extra=info_gen}];sigma=sig_sig gls}, - function - [pftree] -> - {pftree with - goal=gl; - ref=Some (Prim Change_evars,[pftree])} - | _ -> anomaly "change_info : Wrong number of subtrees") - -let tcl_change_info info gls = tcl_change_info_gen (Some (pm_in info)) gls - -let tcl_erase_info gls = tcl_change_info_gen None gls - -let special_whd gl= - let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in - (fun t -> Closure.whd_val infos (Closure.inject t)) - -let special_nf gl= - let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in - (fun t -> Closure.norm_val infos (Closure.inject t)) - -let is_good_inductive env ind = - let mib,oib = Inductive.lookup_mind_specif env ind in - oib.mind_nrealargs = 0 && not (Inductiveops.mis_is_recursive (ind,mib,oib)) - -let check_not_per pts = - if not (Proof_trees.is_complete_proof (proof_of_pftreestate pts)) then - match get_stack pts with - Per (_,_,_,_)::_ -> - error "You are inside a proof per cases/induction.\n\ -Please \"suppose\" something or \"end\" it now." - | _ -> () - -let mk_evd metalist gls = - let evd0= create_goal_evar_defs (sig_sig gls) in - let add_one (meta,typ) evd = - meta_declare meta typ evd in - List.fold_right add_one metalist evd0 - -let is_tmp id = (string_of_id id).[0] = '_' - -let tmp_ids gls = - let ctx = pf_hyps gls in - match ctx with - [] -> [] - | _::q -> List.filter is_tmp (ids_of_named_context q) - -let clean_tmp gls = - let clean_id id0 gls0 = - tclTRY (clear [id0]) gls0 in - let rec clean_all = function - [] -> tclIDTAC - | id :: rest -> tclTHEN (clean_id id) (clean_all rest) - in - clean_all (tmp_ids gls) gls - -let assert_postpone id t = - assert_tac (Name id) t - -(* start a proof *) - -let start_proof_tac gls= - let gl=sig_it gls in - let info={pm_stack=[]} in - {it=[{gl with evar_extra=Some (pm_in info)}];sigma=sig_sig gls}, - function - [pftree] -> - {pftree with - goal=gl; - ref=Some (Decl_proof true,[pftree])} - | _ -> anomaly "Dem : Wrong number of subtrees" - -let go_to_proof_mode () = - Pfedit.mutate - (fun pts -> nth_unproven 1 (solve_pftreestate start_proof_tac pts)) - -(* closing gaps *) - -let daimon_tac gls = - set_daimon_flag (); - ({it=[];sigma=sig_sig gls}, - function - [] -> - {open_subgoals=0; - goal=sig_it gls; - ref=Some (Daimon,[])} - | _ -> anomaly "Daimon: Wrong number of subtrees") - -let daimon _ pftree = - set_daimon_flag (); - {pftree with - open_subgoals=0; - ref=Some (Daimon,[])} - -let daimon_subtree = map_pftreestate (fun _ -> frontier_mapi daimon ) - -(* marking closed blocks *) - -let rec is_focussing_instr = function - Pthus i | Pthen i | Phence i -> is_focussing_instr i - | Pescape | Pper _ | Pclaim _ | Pfocus _ - | Psuppose _ | Pcase (_,_,_) -> true - | _ -> false - -let mark_rule_as_done = function - Decl_proof true -> Decl_proof false - | Decl_proof false -> - anomaly "already marked as done" - | Nested(Proof_instr (lock_focus,instr),spfl) -> - if lock_focus then - Nested(Proof_instr (false,instr),spfl) - else - anomaly "already marked as done" - | _ -> anomaly "mark_rule_as_done" - -let mark_proof_tree_as_done pt = - match pt.ref with - None -> anomaly "mark_proof_tree_as_done" - | Some (r,spfl) -> - {pt with ref= Some (mark_rule_as_done r,spfl)} - -let mark_as_done pts = - map_pftreestate - (fun _ -> mark_proof_tree_as_done) - (up_to_matching_rule is_focussing_command pts) - -(* post-instruction focus management *) - -let goto_current_focus pts = up_until_matching_rule is_focussing_command pts - -let goto_current_focus_or_top pts = - try - up_until_matching_rule is_focussing_command pts - with Not_found -> top_of_tree pts - -(* return *) - -let close_tactic_mode pts = - let pts1= - try goto_current_focus pts - with Not_found -> - error "\"return\" cannot be used outside of Declarative Proof Mode." in - let pts2 = daimon_subtree pts1 in - let pts3 = mark_as_done pts2 in - goto_current_focus pts3 - -let return_from_tactic_mode () = Pfedit.mutate close_tactic_mode - -(* end proof/claim *) - -let close_block bt pts = - let stack = - if Proof_trees.is_complete_proof (proof_of_pftreestate pts) then - get_top_stack pts - else - get_stack pts in - match bt,stack with - B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] -> - daimon_subtree (goto_current_focus pts) - | _, Claim::_ -> - error "\"end claim\" expected." - | _, Focus_claim::_ -> - error "\"end focus\" expected." - | _, [] -> - error "\"end proof\" expected." - | _, (Per (et,_,_,_)::_|Suppose_case::Per (et,_,_,_)::_) -> - begin - match et with - ET_Case_analysis -> error "\"end cases\" expected." - | ET_Induction -> error "\"end induction\" expected." - end - | _,_ -> anomaly "Lonely suppose on stack." - -(* utility for suppose / suppose it is *) - -let close_previous_case pts = - if - Proof_trees.is_complete_proof (proof_of_pftreestate pts) - then - match get_top_stack pts with - Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..." - | Suppose_case :: Per (et,_,_,_) :: _ -> - goto_current_focus (mark_as_done pts) - | _ -> error "Not inside a proof per cases or induction." - else - match get_stack pts with - Per (et,_,_,_) :: _ -> pts - | Suppose_case :: Per (et,_,_,_) :: _ -> - goto_current_focus (mark_as_done (daimon_subtree pts)) - | _ -> error "Not inside a proof per cases or induction." - -(* Proof instructions *) - -(* automation *) - -let filter_hyps f gls = - let filter_aux (id,_,_) = - if f id then - tclIDTAC - else - tclTRY (clear [id]) in - tclMAP filter_aux (Environ.named_context_of_val gls.it.evar_hyps) gls - -let local_hyp_prefix = id_of_string "___" - -let add_justification_hyps keep items gls = - let add_aux c gls= - match kind_of_term c with - Var id -> - keep:=Idset.add id !keep; - tclIDTAC gls - | _ -> - let id=pf_get_new_id local_hyp_prefix gls in - keep:=Idset.add id !keep; - tclTHEN (letin_tac None (Names.Name id) c None Tacexpr.nowhere) - (thin_body [id]) gls in - tclMAP add_aux items gls - -let prepare_goal items gls = - let tokeep = ref Idset.empty in - let auxres = add_justification_hyps tokeep items gls in - tclTHENLIST - [ (fun _ -> auxres); - filter_hyps (let keep = !tokeep in fun id -> Idset.mem id keep)] gls - -let my_automation_tac = ref - (fun gls -> anomaly "No automation registered") - -let register_automation_tac tac = my_automation_tac:= tac - -let automation_tac gls = !my_automation_tac gls - -let justification tac gls= - tclORELSE - (tclSOLVE [tclTHEN tac assumption]) - (fun gls -> - if get_strictness () then - error "Insufficient justification." - else - begin - msg_warning (str "Insufficient justification."); - daimon_tac gls - end) gls - -let default_justification elems gls= - justification (tclTHEN (prepare_goal elems) automation_tac) gls - -(* code for conclusion refining *) - -let constant dir s = lazy (Coqlib.gen_constant "Declarative" dir s) - -let _and = constant ["Init";"Logic"] "and" - -let _and_rect = constant ["Init";"Logic"] "and_rect" - -let _prod = constant ["Init";"Datatypes"] "prod" - -let _prod_rect = constant ["Init";"Datatypes"] "prod_rect" - -let _ex = constant ["Init";"Logic"] "ex" - -let _ex_ind = constant ["Init";"Logic"] "ex_ind" - -let _sig = constant ["Init";"Specif"] "sig" - -let _sig_rect = constant ["Init";"Specif"] "sig_rect" - -let _sigT = constant ["Init";"Specif"] "sigT" - -let _sigT_rect = constant ["Init";"Specif"] "sigT_rect" - -type stackd_elt = -{se_meta:metavariable; - se_type:types; - se_last_meta:metavariable; - se_meta_list:(metavariable*types) list; - se_evd: evar_map} - -let rec replace_in_list m l = function - [] -> raise Not_found - | c::q -> if m=fst c then l@q else c::replace_in_list m l q - -let enstack_subsubgoals env se stack gls= - let hd,params = decompose_app (special_whd gls se.se_type) in - match kind_of_term hd with - Ind ind when is_good_inductive env ind -> - let mib,oib= - Inductive.lookup_mind_specif env ind in - let gentypes= - Inductive.arities_of_constructors ind (mib,oib) in - let process i gentyp = - let constructor = mkConstruct(ind,succ i) - (* constructors numbering*) in - let appterm = applist (constructor,params) in - let apptype = Term.prod_applist gentyp params in - let rc,_ = Reduction.dest_prod env apptype in - let rec meta_aux last lenv = function - [] -> (last,lenv,[]) - | (nam,_,typ)::q -> - let nlast=succ last in - let (llast,holes,metas) = - meta_aux nlast (mkMeta nlast :: lenv) q in - (llast,holes,(nlast,special_nf gls (substl lenv typ))::metas) in - let (nlast,holes,nmetas) = - meta_aux se.se_last_meta [] (List.rev rc) in - let refiner = applist (appterm,List.rev holes) in - let evd = meta_assign se.se_meta - (refiner,(ConvUpToEta 0,TypeProcessed (* ? *))) se.se_evd in - let ncreated = replace_in_list - se.se_meta nmetas se.se_meta_list in - let evd0 = List.fold_left - (fun evd (m,typ) -> meta_declare m typ evd) evd nmetas in - List.iter (fun (m,typ) -> - Stack.push - {se_meta=m; - se_type=typ; - se_evd=evd0; - se_meta_list=ncreated; - se_last_meta=nlast} stack) (List.rev nmetas) - in - Array.iteri process gentypes - | _ -> () - -let rec nf_list evd = - function - [] -> [] - | (m,typ)::others -> - if meta_defined evd m then - nf_list evd others - else - (m,nf_meta evd typ)::nf_list evd others - -let find_subsubgoal c ctyp skip submetas gls = - let env= pf_env gls in - let concl = pf_concl gls in - let evd = mk_evd ((0,concl)::submetas) gls in - let stack = Stack.create () in - let max_meta = - List.fold_left (fun a (m,_) -> max a m) 0 submetas in - let _ = Stack.push - {se_meta=0; - se_type=concl; - se_last_meta=max_meta; - se_meta_list=[0,concl]; - se_evd=evd} stack in - let rec dfs n = - let se = Stack.pop stack in - try - let unifier = - Unification.w_unify true env Reduction.CUMUL - ctyp se.se_type se.se_evd in - if n <= 0 then - {se with - se_evd=meta_assign se.se_meta - (c,(ConvUpToEta 0,TypeNotProcessed (* ?? *))) unifier; - se_meta_list=replace_in_list - se.se_meta submetas se.se_meta_list} - else - dfs (pred n) - with _ -> - begin - enstack_subsubgoals env se stack gls; - dfs n - end in - let nse= try dfs skip with Stack.Empty -> raise Not_found in - nf_list nse.se_evd nse.se_meta_list,nf_meta nse.se_evd (mkMeta 0) - -let concl_refiner metas body gls = - let concl = pf_concl gls in - let evd = sig_sig gls in - let env = pf_env gls in - let sort = family_of_sort (Typing.sort_of env evd concl) in - let rec aux env avoid subst = function - [] -> anomaly "concl_refiner: cannot happen" - | (n,typ)::rest -> - let _A = subst_meta subst typ in - let x = id_of_name_using_hdchar env _A Anonymous in - let _x = fresh_id avoid x gls in - let nenv = Environ.push_named (_x,None,_A) env in - let asort = family_of_sort (Typing.sort_of nenv evd _A) in - let nsubst = (n,mkVar _x)::subst in - if rest = [] then - asort,_A,mkNamedLambda _x _A (subst_meta nsubst body) - else - let bsort,_B,nbody = - aux nenv (_x::avoid) ((n,mkVar _x)::subst) rest in - let body = mkNamedLambda _x _A nbody in - if occur_term (mkVar _x) _B then - begin - let _P = mkNamedLambda _x _A _B in - match bsort,sort with - InProp,InProp -> - let _AxB = mkApp(Lazy.force _ex,[|_A;_P|]) in - InProp,_AxB, - mkApp(Lazy.force _ex_ind,[|_A;_P;concl;body|]) - | InProp,_ -> - let _AxB = mkApp(Lazy.force _sig,[|_A;_P|]) in - let _P0 = mkLambda(Anonymous,_AxB,concl) in - InType,_AxB, - mkApp(Lazy.force _sig_rect,[|_A;_P;_P0;body|]) - | _,_ -> - let _AxB = mkApp(Lazy.force _sigT,[|_A;_P|]) in - let _P0 = mkLambda(Anonymous,_AxB,concl) in - InType,_AxB, - mkApp(Lazy.force _sigT_rect,[|_A;_P;_P0;body|]) - end - else - begin - match asort,bsort with - InProp,InProp -> - let _AxB = mkApp(Lazy.force _and,[|_A;_B|]) in - InProp,_AxB, - mkApp(Lazy.force _and_rect,[|_A;_B;concl;body|]) - |_,_ -> - let _AxB = mkApp(Lazy.force _prod,[|_A;_B|]) in - let _P0 = mkLambda(Anonymous,_AxB,concl) in - InType,_AxB, - mkApp(Lazy.force _prod_rect,[|_A;_B;_P0;body|]) - end - in - let (_,_,prf) = aux env [] [] metas in - mkApp(prf,[|mkMeta 1|]) - -let thus_tac c ctyp submetas gls = - let list,proof = - try - find_subsubgoal c ctyp 0 submetas gls - with Not_found -> - error "I could not relate this statement to the thesis." in - if list = [] then - exact_check proof gls - else - let refiner = concl_refiner list proof gls in - Tactics.refine refiner gls - -(* general forward step *) - -let mk_stat_or_thesis info gls = function - This c -> c - | Thesis (For _ ) -> - error "\"thesis for ...\" is not applicable here." - | Thesis Plain -> pf_concl gls - -let just_tac _then cut info gls0 = - let items_tac gls = - match cut.cut_by with - None -> tclIDTAC gls - | Some items -> - let items_ = - if _then then - let last_id = get_last (pf_env gls) in - (mkVar last_id)::items - else items - in prepare_goal items_ gls in - let method_tac gls = - match cut.cut_using with - None -> - automation_tac gls - | Some tac -> - (Tacinterp.eval_tactic tac) gls in - justification (tclTHEN items_tac method_tac) gls0 - -let instr_cut mkstat _thus _then cut gls0 = - let info = get_its_info gls0 in - let stat = cut.cut_stat in - let (c_id,_) = match stat.st_label with - Anonymous -> - pf_get_new_id (id_of_string "_fact") gls0,false - | Name id -> id,true in - let c_stat = mkstat info gls0 stat.st_it in - let thus_tac gls= - if _thus then - thus_tac (mkVar c_id) c_stat [] gls - else tclIDTAC gls in - tclTHENS (assert_postpone c_id c_stat) - [tclTHEN tcl_erase_info (just_tac _then cut info); - thus_tac] gls0 - - - -(* iterated equality *) -let _eq = Libnames.constr_of_global (Coqlib.glob_eq) - -let decompose_eq id gls = - let typ = pf_get_hyp_typ gls id in - let whd = (special_whd gls typ) in - match kind_of_term whd with - App (f,args)-> - if eq_constr f _eq && (Array.length args)=3 - then (args.(0), - args.(1), - args.(2)) - else error "Previous step is not an equality." - | _ -> error "Previous step is not an equality." - -let instr_rew _thus rew_side cut gls0 = - let last_id = - try get_last (pf_env gls0) with _ -> error "No previous equality." in - let typ,lhs,rhs = decompose_eq last_id gls0 in - let items_tac gls = - match cut.cut_by with - None -> tclIDTAC gls - | Some items -> prepare_goal items gls in - let method_tac gls = - match cut.cut_using with - None -> - automation_tac gls - | Some tac -> - (Tacinterp.eval_tactic tac) gls in - let just_tac gls = - justification (tclTHEN items_tac method_tac) gls in - let (c_id,_) = match cut.cut_stat.st_label with - Anonymous -> - pf_get_new_id (id_of_string "_eq") gls0,false - | Name id -> id,true in - let thus_tac new_eq gls= - if _thus then - thus_tac (mkVar c_id) new_eq [] gls - else tclIDTAC gls in - match rew_side with - Lhs -> - let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in - tclTHENS (assert_postpone c_id new_eq) - [tclTHEN tcl_erase_info - (tclTHENS (transitivity lhs) - [just_tac;exact_check (mkVar last_id)]); - thus_tac new_eq] gls0 - | Rhs -> - let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in - tclTHENS (assert_postpone c_id new_eq) - [tclTHEN tcl_erase_info - (tclTHENS (transitivity rhs) - [exact_check (mkVar last_id);just_tac]); - thus_tac new_eq] gls0 - - - -(* tactics for claim/focus *) - -let instr_claim _thus st gls0 = - let info = get_its_info gls0 in - let (id,_) = match st.st_label with - Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false - | Name id -> id,true in - let thus_tac gls= - if _thus then - thus_tac (mkVar id) st.st_it [] gls - else tclIDTAC gls in - let ninfo1 = {pm_stack= - (if _thus then Focus_claim else Claim)::info.pm_stack} in - tclTHENS (assert_postpone id st.st_it) - [tcl_change_info ninfo1; - thus_tac] gls0 - -(* tactics for assume *) - -let push_intro_tac coerce nam gls = - let (hid,_) = - match nam with - Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false - | Name id -> id,true in - tclTHENLIST - [intro_mustbe_force hid; - coerce hid] - gls - -let assume_tac hyps gls = - List.fold_right - (fun (Hvar st | Hprop st) -> - tclTHEN - (push_intro_tac - (fun id -> - convert_hyp (id,None,st.st_it)) st.st_label)) - hyps tclIDTAC gls - -let assume_hyps_or_theses hyps gls = - List.fold_right - (function - (Hvar {st_label=nam;st_it=c} | Hprop {st_label=nam;st_it=This c}) -> - tclTHEN - (push_intro_tac - (fun id -> - convert_hyp (id,None,c)) nam) - | Hprop {st_label=nam;st_it=Thesis (tk)} -> - tclTHEN - (push_intro_tac - (fun id -> tclIDTAC) nam)) - hyps tclIDTAC gls - -let assume_st hyps gls = - List.fold_right - (fun st -> - tclTHEN - (push_intro_tac - (fun id -> convert_hyp (id,None,st.st_it)) st.st_label)) - hyps tclIDTAC gls - -let assume_st_letin hyps gls = - List.fold_right - (fun st -> - tclTHEN - (push_intro_tac - (fun id -> - convert_hyp (id,Some (fst st.st_it),snd st.st_it)) st.st_label)) - hyps tclIDTAC gls - -(* suffices *) - -let rec metas_from n hyps = - match hyps with - _ :: q -> n :: metas_from (succ n) q - | [] -> [] - -let rec build_product args body = - match args with - (Hprop st| Hvar st )::rest -> - let pprod= lift 1 (build_product rest body) in - let lbody = - match st.st_label with - Anonymous -> pprod - | Name id -> subst_term (mkVar id) pprod in - mkProd (st.st_label, st.st_it, lbody) - | [] -> body - -let rec build_applist prod = function - [] -> [],prod - | n::q -> - let (_,typ,_) = destProd prod in - let ctx,head = build_applist (Term.prod_applist prod [mkMeta n]) q in - (n,typ)::ctx,head - -let instr_suffices _then cut gls0 = - let info = get_its_info gls0 in - let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in - let ctx,hd = cut.cut_stat in - let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in - let metas = metas_from 1 ctx in - let c_ctx,c_head = build_applist c_stat metas in - let c_term = applist (mkVar c_id,List.map mkMeta metas) in - let thus_tac gls= - thus_tac c_term c_head c_ctx gls in - tclTHENS (assert_postpone c_id c_stat) - [tclTHENLIST - [ assume_tac ctx; - tcl_erase_info; - just_tac _then cut info]; - thus_tac] gls0 - -(* tactics for consider/given *) - -let conjunction_arity id gls = - let typ = pf_get_hyp_typ gls id in - let hd,params = decompose_app (special_whd gls typ) in - let env =pf_env gls in - match kind_of_term hd with - Ind ind when is_good_inductive env ind -> - let mib,oib= - Inductive.lookup_mind_specif env ind in - let gentypes= - Inductive.arities_of_constructors ind (mib,oib) in - let _ = if Array.length gentypes <> 1 then raise Not_found in - let apptype = Term.prod_applist gentypes.(0) params in - let rc,_ = Reduction.dest_prod env apptype in - List.length rc - | _ -> raise Not_found - -let rec intron_then n ids ltac gls = - if n<=0 then - ltac ids gls - else - let id = pf_get_new_id (id_of_string "_tmp") gls in - tclTHEN - (intro_mustbe_force id) - (intron_then (pred n) (id::ids) ltac) gls - - -let rec consider_match may_intro introduced available expected gls = - match available,expected with - [],[] -> - tclIDTAC gls - | _,[] -> error "Last statements do not match a complete hypothesis." - (* should tell which ones *) - | [],hyps -> - if may_intro then - begin - let id = pf_get_new_id (id_of_string "_tmp") gls in - tclIFTHENELSE - (intro_mustbe_force id) - (consider_match true [] [id] hyps) - (fun _ -> - error "Not enough sub-hypotheses to match statements.") - gls - end - else - error "Not enough sub-hypotheses to match statements." - (* should tell which ones *) - | id::rest_ids,(Hvar st | Hprop st)::rest -> - tclIFTHENELSE (convert_hyp (id,None,st.st_it)) - begin - match st.st_label with - Anonymous -> - consider_match may_intro ((id,false)::introduced) rest_ids rest - | Name hid -> - tclTHENLIST - [rename_hyp [id,hid]; - consider_match may_intro ((hid,true)::introduced) rest_ids rest] - end - begin - (fun gls -> - let nhyps = - try conjunction_arity id gls with - Not_found -> error "Matching hypothesis not found." in - tclTHENLIST - [general_case_analysis false (mkVar id,NoBindings); - intron_then nhyps [] - (fun l -> consider_match may_intro introduced - (List.rev_append l rest_ids) expected)] gls) - end - gls - -let consider_tac c hyps gls = - match kind_of_term (strip_outer_cast c) with - Var id -> - consider_match false [] [id] hyps gls - | _ -> - let id = pf_get_new_id (id_of_string "_tmp") gls in - tclTHEN - (forward None (Some (dummy_loc, Genarg.IntroIdentifier id)) c) - (consider_match false [] [id] hyps) gls - - -let given_tac hyps gls = - consider_match true [] [] hyps gls - -(* tactics for take *) - -let rec take_tac wits gls = - match wits with - [] -> tclIDTAC gls - | wit::rest -> - let typ = pf_type_of gls wit in - tclTHEN (thus_tac wit typ []) (take_tac rest) gls - - -(* tactics for define *) - -let rec build_function args body = - match args with - st::rest -> - let pfun= lift 1 (build_function rest body) in - let id = match st.st_label with - Anonymous -> assert false - | Name id -> id in - mkLambda (Name id, st.st_it, subst_term (mkVar id) pfun) - | [] -> body - -let define_tac id args body gls = - let t = build_function args body in - letin_tac None (Name id) t None Tacexpr.nowhere gls - -(* tactics for reconsider *) - -let cast_tac id_or_thesis typ gls = - match id_or_thesis with - This id -> - let (_,body,_) = pf_get_hyp gls id in - convert_hyp (id,body,typ) gls - | Thesis (For _ ) -> - error "\"thesis for ...\" is not applicable here." - | Thesis Plain -> - convert_concl typ DEFAULTcast gls - -(* per cases *) - -let is_rec_pos (main_ind,wft) = - match main_ind with - None -> false - | Some index -> - match fst (Rtree.dest_node wft) with - Mrec i when i = index -> true - | _ -> false - -let rec constr_trees (main_ind,wft) ind = - match Rtree.dest_node wft with - Norec,_ -> - let itree = - (snd (Global.lookup_inductive ind)).mind_recargs in - constr_trees (None,itree) ind - | _,constrs -> main_ind,constrs - -let ind_args rp ind = - let main_ind,constrs = constr_trees rp ind in - let args ctree = - Array.map (fun t -> main_ind,t) (snd (Rtree.dest_node ctree)) in - Array.map args constrs - -let init_tree ids ind rp nexti = - let indargs = ind_args rp ind in - let do_i i arp = (Array.map is_rec_pos arp),nexti i arp in - Split_patt (ids,ind,Array.mapi do_i indargs) - -let map_tree_rp rp id_fun mapi = function - Split_patt (ids,ind,branches) -> - let indargs = ind_args rp ind in - let do_i i (recargs,bri) = recargs,mapi i indargs.(i) bri in - Split_patt (id_fun ids,ind,Array.mapi do_i branches) - | _ -> failwith "map_tree_rp: not a splitting node" - -let map_tree id_fun mapi = function - Split_patt (ids,ind,branches) -> - let do_i i (recargs,bri) = recargs,mapi i bri in - Split_patt (id_fun ids,ind,Array.mapi do_i branches) - | _ -> failwith "map_tree: not a splitting node" - - -let start_tree env ind rp = - init_tree Idset.empty ind rp (fun _ _ -> None) - -let build_per_info etype casee gls = - let concl=pf_concl gls in - let env=pf_env gls in - let ctyp=pf_type_of gls casee in - let is_dep = dependent casee concl in - let hd,args = decompose_app (special_whd gls ctyp) in - let ind = - try - destInd hd - with _ -> - error "Case analysis must be done on an inductive object." in - let mind,oind = Global.lookup_inductive ind in - let nparams,index = - match etype with - ET_Induction -> mind.mind_nparams_rec,Some (snd ind) - | _ -> mind.mind_nparams,None in - let params,real_args = list_chop nparams args in - let abstract_obj c body = - let typ=pf_type_of gls c in - lambda_create env (typ,subst_term c body) in - let pred= List.fold_right abstract_obj - real_args (lambda_create env (ctyp,subst_term casee concl)) in - is_dep, - {per_casee=casee; - per_ctype=ctyp; - per_ind=ind; - per_pred=pred; - per_args=real_args; - per_params=params; - per_nparams=nparams; - per_wf=index,oind.mind_recargs} - -let per_tac etype casee gls= - let env=pf_env gls in - let info = get_its_info gls in - match casee with - Real c -> - let is_dep,per_info = build_per_info etype c gls in - let ek = - if is_dep then - EK_dep (start_tree env per_info.per_ind per_info.per_wf) - else EK_unknown in - tcl_change_info - {pm_stack= - Per(etype,per_info,ek,[])::info.pm_stack} gls - | Virtual cut -> - assert (cut.cut_stat.st_label=Anonymous); - let id = pf_get_new_id (id_of_string "anonymous_matched") gls in - let c = mkVar id in - let modified_cut = - {cut with cut_stat={cut.cut_stat with st_label=Name id}} in - tclTHEN - (instr_cut (fun _ _ c -> c) false false modified_cut) - (fun gls0 -> - let is_dep,per_info = build_per_info etype c gls0 in - assert (not is_dep); - tcl_change_info - {pm_stack= - Per(etype,per_info,EK_unknown,[])::info.pm_stack} gls0) - gls - -(* suppose *) - -let register_nodep_subcase id= function - Per(et,pi,ek,clauses)::s -> - begin - match ek with - EK_unknown -> clauses,Per(et,pi,EK_nodep,id::clauses)::s - | EK_nodep -> clauses,Per(et,pi,EK_nodep,id::clauses)::s - | EK_dep _ -> error "Do not mix \"suppose\" with \"suppose it is\"." - end - | _ -> anomaly "wrong stack state" - -let suppose_tac hyps gls0 = - let info = get_its_info gls0 in - let thesis = pf_concl gls0 in - let id = pf_get_new_id (id_of_string "subcase_") gls0 in - let clause = build_product hyps thesis in - let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in - let old_clauses,stack = register_nodep_subcase id info.pm_stack in - let ninfo2 = {pm_stack=stack} in - tclTHENS (assert_postpone id clause) - [tclTHENLIST [tcl_change_info ninfo1; - assume_tac hyps; - clear old_clauses]; - tcl_change_info ninfo2] gls0 - -(* suppose it is ... *) - -(* pattern matching compiling *) - -let rec skip_args rest ids n = - if n <= 0 then - Close_patt rest - else - Skip_patt (ids,skip_args rest ids (pred n)) - -let rec tree_of_pats ((id,_) as cpl) pats = - match pats with - [] -> End_patt cpl - | args::stack -> - match args with - [] -> Close_patt (tree_of_pats cpl stack) - | (patt,rp) :: rest_args -> - match patt with - PatVar (_,v) -> - Skip_patt (Idset.singleton id, - tree_of_pats cpl (rest_args::stack)) - | PatCstr (_,(ind,cnum),args,nam) -> - let nexti i ati = - if i = pred cnum then - let nargs = - list_map_i (fun j a -> (a,ati.(j))) 0 args in - Some (Idset.singleton id, - tree_of_pats cpl (nargs::rest_args::stack)) - else None - in init_tree Idset.empty ind rp nexti - -let rec add_branch ((id,_) as cpl) pats tree= - match pats with - [] -> - begin - match tree with - End_patt cpl0 -> End_patt cpl0 - (* this ensures precedence for overlapping patterns *) - | _ -> anomaly "tree is expected to end here" - end - | args::stack -> - match args with - [] -> - begin - match tree with - Close_patt t -> - Close_patt (add_branch cpl stack t) - | _ -> anomaly "we should pop here" - end - | (patt,rp) :: rest_args -> - match patt with - PatVar (_,v) -> - begin - match tree with - Skip_patt (ids,t) -> - Skip_patt (Idset.add id ids, - add_branch cpl (rest_args::stack) t) - | Split_patt (_,_,_) -> - map_tree (Idset.add id) - (fun i bri -> - append_branch cpl 1 (rest_args::stack) bri) - tree - | _ -> anomaly "No pop/stop expected here" - end - | PatCstr (_,(ind,cnum),args,nam) -> - match tree with - Skip_patt (ids,t) -> - let nexti i ati = - if i = pred cnum then - let nargs = - list_map_i (fun j a -> (a,ati.(j))) 0 args in - Some (Idset.add id ids, - add_branch cpl (nargs::rest_args::stack) - (skip_args t ids (Array.length ati))) - else - Some (ids, - skip_args t ids (Array.length ati)) - in init_tree ids ind rp nexti - | Split_patt (_,ind0,_) -> - if (ind <> ind0) then error - (* this can happen with coercions *) - "Case pattern belongs to wrong inductive type."; - let mapi i ati bri = - if i = pred cnum then - let nargs = - list_map_i (fun j a -> (a,ati.(j))) 0 args in - append_branch cpl 0 - (nargs::rest_args::stack) bri - else bri in - map_tree_rp rp (fun ids -> ids) mapi tree - | _ -> anomaly "No pop/stop expected here" -and append_branch ((id,_) as cpl) depth pats = function - Some (ids,tree) -> - Some (Idset.add id ids,append_tree cpl depth pats tree) - | None -> - Some (Idset.singleton id,tree_of_pats cpl pats) -and append_tree ((id,_) as cpl) depth pats tree = - if depth<=0 then add_branch cpl pats tree - else match tree with - Close_patt t -> - Close_patt (append_tree cpl (pred depth) pats t) - | Skip_patt (ids,t) -> - Skip_patt (Idset.add id ids,append_tree cpl depth pats t) - | End_patt _ -> anomaly "Premature end of branch" - | Split_patt (_,_,_) -> - map_tree (Idset.add id) - (fun i bri -> append_branch cpl (succ depth) pats bri) tree - -(* suppose it is *) - -let rec st_assoc id = function - [] -> raise Not_found - | st::_ when st.st_label = id -> st.st_it - | _ :: rest -> st_assoc id rest - -let thesis_for obj typ per_info env= - let rc,hd1=decompose_prod typ in - let cind,all_args=decompose_app typ in - let ind = destInd cind in - let _ = if ind <> per_info.per_ind then - errorlabstrm "thesis_for" - ((Printer.pr_constr_env env obj) ++ spc () ++ - str"cannot give an induction hypothesis (wrong inductive type).") in - let params,args = list_chop per_info.per_nparams all_args in - let _ = if not (List.for_all2 eq_constr params per_info.per_params) then - errorlabstrm "thesis_for" - ((Printer.pr_constr_env env obj) ++ spc () ++ - str "cannot give an induction hypothesis (wrong parameters).") in - let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in - compose_prod rc (whd_beta Evd.empty hd2) - -let rec build_product_dep pat_info per_info args body gls = - match args with - (Hprop {st_label=nam;st_it=This c} - | Hvar {st_label=nam;st_it=c})::rest -> - let pprod= - lift 1 (build_product_dep pat_info per_info rest body gls) in - let lbody = - match nam with - Anonymous -> body - | Name id -> subst_var id pprod in - mkProd (nam,c,lbody) - | Hprop ({st_it=Thesis tk} as st)::rest -> - let pprod= - lift 1 (build_product_dep pat_info per_info rest body gls) in - let lbody = - match st.st_label with - Anonymous -> body - | Name id -> subst_var id pprod in - let ptyp = - match tk with - For id -> - let obj = mkVar id in - let typ = - try st_assoc (Name id) pat_info.pat_vars - with Not_found -> - snd (st_assoc (Name id) pat_info.pat_aliases) in - thesis_for obj typ per_info (pf_env gls) - | Plain -> pf_concl gls in - mkProd (st.st_label,ptyp,lbody) - | [] -> body - -let build_dep_clause params pat_info per_info hyps gls = - let concl= - thesis_for pat_info.pat_constr pat_info.pat_typ per_info (pf_env gls) in - let open_clause = - build_product_dep pat_info per_info hyps concl gls in - let prod_one st body = - match st.st_label with - Anonymous -> mkProd(Anonymous,st.st_it,lift 1 body) - | Name id -> mkNamedProd id st.st_it (lift 1 body) in - let let_one_in st body = - match st.st_label with - Anonymous -> mkLetIn(Anonymous,fst st.st_it,snd st.st_it,lift 1 body) - | Name id -> - mkNamedLetIn id (fst st.st_it) (snd st.st_it) (lift 1 body) in - let aliased_clause = - List.fold_right let_one_in pat_info.pat_aliases open_clause in - List.fold_right prod_one (params@pat_info.pat_vars) aliased_clause - -let rec register_dep_subcase id env per_info pat = function - EK_nodep -> error "Only \"suppose it is\" can be used here." - | EK_unknown -> - register_dep_subcase id env per_info pat - (EK_dep (start_tree env per_info.per_ind per_info.per_wf)) - | EK_dep tree -> EK_dep (add_branch id [[pat,per_info.per_wf]] tree) - -let case_tac params pat_info hyps gls0 = - let info = get_its_info gls0 in - let id = pf_get_new_id (id_of_string "subcase_") gls0 in - let et,per_info,ek,old_clauses,rest = - match info.pm_stack with - Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest) - | _ -> anomaly "wrong place for cases" in - let clause = build_dep_clause params pat_info per_info hyps gls0 in - let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in - let nek = - register_dep_subcase (id,(List.length params,List.length hyps)) - (pf_env gls0) per_info pat_info.pat_pat ek in - let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in - tclTHENS (assert_postpone id clause) - [tclTHENLIST - [tcl_change_info ninfo1; - assume_st (params@pat_info.pat_vars); - assume_st_letin pat_info.pat_aliases; - assume_hyps_or_theses hyps; - clear old_clauses]; - tcl_change_info ninfo2] gls0 - -(* end cases *) - -type instance_stack = - (constr option*(constr list) list) list - -let initial_instance_stack ids = - List.map (fun id -> id,[None,[]]) ids - -let push_one_arg arg = function - [] -> anomaly "impossible" - | (head,args) :: ctx -> - ((head,(arg::args)) :: ctx) - -let push_arg arg stacks = - List.map (fun (id,stack) -> (id,push_one_arg arg stack)) stacks - - -let push_one_head c ids (id,stack) = - let head = if Idset.mem id ids then Some c else None in - id,(head,[]) :: stack - -let push_head c ids stacks = - List.map (push_one_head c ids) stacks - -let pop_one (id,stack) = - let nstack= - match stack with - [] -> anomaly "impossible" - | [c] as l -> l - | (Some head,args)::(head0,args0)::ctx -> - let arg = applist (head,(List.rev args)) in - (head0,(arg::args0))::ctx - | (None,args)::(head0,args0)::ctx -> - (head0,(args@args0))::ctx - in id,nstack - -let pop_stacks stacks = - List.map pop_one stacks - -let hrec_for fix_id per_info gls obj_id = - let obj=mkVar obj_id in - let typ=pf_get_hyp_typ gls obj_id in - let rc,hd1=decompose_prod typ in - let cind,all_args=decompose_app typ in - let ind = destInd cind in assert (ind=per_info.per_ind); - let params,args= list_chop per_info.per_nparams all_args in - assert begin - try List.for_all2 eq_constr params per_info.per_params with - Invalid_argument _ -> false end; - let hd2 = applist (mkVar fix_id,args@[obj]) in - compose_lam rc (whd_beta gls.sigma hd2) - - -let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = - match tree, objs with - Close_patt t,_ -> - let args0 = pop_stacks args in - execute_cases fix_name per_info tacnext args0 objs nhrec t gls - | Skip_patt (_,t),skipped::next_objs -> - let args0 = push_arg skipped args in - execute_cases fix_name per_info tacnext args0 next_objs nhrec t gls - | End_patt (id,(nparams,nhyps)),[] -> - begin - match List.assoc id args with - [None,br_args] -> - let all_metas = - list_tabulate (fun n -> mkMeta (succ n)) (nparams + nhyps) in - let param_metas,hyp_metas = list_chop nparams all_metas in - tclTHEN - (tclDO nhrec introf) - (tacnext - (applist (mkVar id, - List.append param_metas - (List.rev_append br_args hyp_metas)))) gls - | _ -> anomaly "wrong stack size" - end - | Split_patt (ids,ind,br), casee::next_objs -> - let (mind,oind) as spec = Global.lookup_inductive ind in - let nparams = mind.mind_nparams in - let concl=pf_concl gls in - let env=pf_env gls in - let ctyp=pf_type_of gls casee in - let hd,all_args = decompose_app (special_whd gls ctyp) in - let _ = assert (destInd hd = ind) in (* just in case *) - let params,real_args = list_chop nparams all_args in - let abstract_obj c body = - let typ=pf_type_of gls c in - lambda_create env (typ,subst_term c body) in - let elim_pred = List.fold_right abstract_obj - real_args (lambda_create env (ctyp,subst_term casee concl)) in - let case_info = Inductiveops.make_case_info env ind RegularStyle in - let gen_arities = Inductive.arities_of_constructors ind spec in - let f_ids typ = - let sign = - (prod_assum (Term.prod_applist typ params)) in - find_intro_names sign gls in - let constr_args_ids = Array.map f_ids gen_arities in - let case_term = - mkCase(case_info,elim_pred,casee, - Array.mapi (fun i _ -> mkMeta (succ i)) constr_args_ids) in - let branch_tac i (recargs,bro) gls0 = - let args_ids = constr_args_ids.(i) in - let rec aux n = function - [] -> - assert (n=Array.length recargs); - next_objs,[],nhrec - | id :: q -> - let objs,recs,nrec = aux (succ n) q in - if recargs.(n) - then (mkVar id::objs),(id::recs),succ nrec - else (mkVar id::objs),recs,nrec in - let objs,recs,nhrec = aux 0 args_ids in - tclTHENLIST - [tclMAP intro_mustbe_force args_ids; - begin - fun gls1 -> - let hrecs = - List.map - (fun id -> - hrec_for (out_name fix_name) per_info gls1 id) - recs in - generalize hrecs gls1 - end; - match bro with - None -> - msg_warning (str "missing case"); - tacnext (mkMeta 1) - | Some (sub_ids,tree) -> - let br_args = - List.filter - (fun (id,_) -> Idset.mem id sub_ids) args in - let construct = - applist (mkConstruct(ind,succ i),params) in - let p_args = - push_head construct ids br_args in - execute_cases fix_name per_info tacnext - p_args objs nhrec tree] gls0 in - tclTHENSV - (refine case_term) - (Array.mapi branch_tac br) gls - | Split_patt (_, _, _) , [] -> - anomaly "execute_cases : Nothing to split" - | Skip_patt _ , [] -> - anomaly "execute_cases : Nothing to skip" - | End_patt (_,_) , _ :: _ -> - anomaly "execute_cases : End of branch with garbage left" - -let understand_my_constr c gls = - let env = pf_env gls in - let nc = names_of_rel_context env in - let rawc = Detyping.detype false [] nc c in - let rec frob = function REvar _ -> RHole (dummy_loc,QuestionMark Expand) | rc -> map_rawconstr frob rc in - Pretyping.Default.understand_tcc (sig_sig gls) env ~expected_type:(pf_concl gls) (frob rawc) - -let set_refine,my_refine = -let refine = ref (fun (_:open_constr) -> (assert false : tactic) ) in -((fun tac -> refine:= tac), -(fun c gls -> - let oc = understand_my_constr c gls in - !refine oc gls)) - -(* end focus/claim *) - -let end_tac et2 gls = - let info = get_its_info gls in - let et1,pi,ek,clauses = - match info.pm_stack with - Suppose_case::_ -> - anomaly "This case should already be trapped" - | Claim::_ -> - error "\"end claim\" expected." - | Focus_claim::_ -> - error "\"end focus\" expected." - | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses) - | [] -> - anomaly "This case should already be trapped" in - let et = - if et1 <> et2 then - match et1 with - ET_Case_analysis -> - error "\"end cases\" expected." - | ET_Induction -> - error "\"end induction\" expected." - else et1 in - tclTHEN - tcl_erase_info - begin - match et,ek with - _,EK_unknown -> - tclSOLVE [simplest_elim pi.per_casee] - | ET_Case_analysis,EK_nodep -> - tclTHEN - (general_case_analysis false (pi.per_casee,NoBindings)) - (default_justification (List.map mkVar clauses)) - | ET_Induction,EK_nodep -> - tclTHENLIST - [generalize (pi.per_args@[pi.per_casee]); - simple_induct (AnonHyp (succ (List.length pi.per_args))); - default_justification (List.map mkVar clauses)] - | ET_Case_analysis,EK_dep tree -> - execute_cases Anonymous pi - (fun c -> tclTHENLIST - [my_refine c; - clear clauses; - justification assumption]) - (initial_instance_stack clauses) [pi.per_casee] 0 tree - | ET_Induction,EK_dep tree -> - let nargs = (List.length pi.per_args) in - tclTHEN (generalize (pi.per_args@[pi.per_casee])) - begin - fun gls0 -> - let fix_id = - pf_get_new_id (id_of_string "_fix") gls0 in - let c_id = - pf_get_new_id (id_of_string "_main_arg") gls0 in - tclTHENLIST - [fix (Some fix_id) (succ nargs); - tclDO nargs introf; - intro_mustbe_force c_id; - execute_cases (Name fix_id) pi - (fun c -> - tclTHENLIST - [clear [fix_id]; - my_refine c; - clear clauses; - justification assumption]) - (initial_instance_stack clauses) - [mkVar c_id] 0 tree] gls0 - end - end gls - -(* escape *) - -let escape_tac gls = tcl_erase_info gls - -(* General instruction engine *) - -let rec do_proof_instr_gen _thus _then instr = - match instr with - Pthus i -> - assert (not _thus); - do_proof_instr_gen true _then i - | Pthen i -> - assert (not _then); - do_proof_instr_gen _thus true i - | Phence i -> - assert (not (_then || _thus)); - do_proof_instr_gen true true i - | Pcut c -> - instr_cut mk_stat_or_thesis _thus _then c - | Psuffices c -> - instr_suffices _then c - | Prew (s,c) -> - assert (not _then); - instr_rew _thus s c - | Pconsider (c,hyps) -> consider_tac c hyps - | Pgiven hyps -> given_tac hyps - | Passume hyps -> assume_tac hyps - | Plet hyps -> assume_tac hyps - | Pclaim st -> instr_claim false st - | Pfocus st -> instr_claim true st - | Ptake witl -> take_tac witl - | Pdefine (id,args,body) -> define_tac id args body - | Pcast (id,typ) -> cast_tac id typ - | Pper (et,cs) -> per_tac et cs - | Psuppose hyps -> suppose_tac hyps - | Pcase (params,pat_info,hyps) -> case_tac params pat_info hyps - | Pend (B_elim et) -> end_tac et - | Pend _ -> anomaly "Not applicable" - | Pescape -> escape_tac - -let eval_instr {instr=instr} = - do_proof_instr_gen false false instr - -let rec preprocess pts instr = - match instr with - Phence i |Pthus i | Pthen i -> preprocess pts i - | Psuffices _ | Pcut _ | Passume _ | Plet _ | Pclaim _ | Pfocus _ - | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ - | Pdefine (_,_,_) | Pper _ | Prew _ -> - check_not_per pts; - true,pts - | Pescape -> - check_not_per pts; - true,pts - | Pcase _ | Psuppose _ | Pend (B_elim _) -> - true,close_previous_case pts - | Pend bt -> - false,close_block bt pts - -let rec postprocess pts instr = - match instr with - Phence i | Pthus i | Pthen i -> postprocess pts i - | Pcut _ | Psuffices _ | Passume _ | Plet _ | Pconsider (_,_) | Pcast (_,_) - | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Prew (_,_) -> pts - | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ - | Pescape -> nth_unproven 1 pts - | Pend (B_elim ET_Induction) -> - begin - let pf = proof_of_pftreestate pts in - let (pfterm,_) = extract_open_pftreestate pts in - let env = Evd.evar_env (goal_of_proof pf) in - try - Inductiveops.control_only_guard env pfterm; - goto_current_focus_or_top (mark_as_done pts) - with - Type_errors.TypeError(env, - Type_errors.IllFormedRecBody(_,_,_,_,_)) -> - anomaly "\"end induction\" generated an ill-formed fixpoint" - end - | Pend _ -> - goto_current_focus_or_top (mark_as_done pts) - -let do_instr raw_instr pts = - let has_tactic,pts1 = preprocess pts raw_instr.instr in - let pts2 = - if has_tactic then - let gl = nth_goal_of_pftreestate 1 pts1 in - let env= pf_env gl in - let sigma= project gl in - let ist = {ltacvars = ([],[]); ltacrecvars = []; - gsigma = sigma; genv = env} in - let glob_instr = intern_proof_instr ist raw_instr in - let instr = - interp_proof_instr (get_its_info gl) sigma env glob_instr in - let lock_focus = is_focussing_instr instr.instr in - let marker= Proof_instr (lock_focus,instr) in - solve_nth_pftreestate 1 - (abstract_operation marker (tclTHEN (eval_instr instr) clean_tmp)) pts1 - else pts1 in - postprocess pts2 raw_instr.instr - -let proof_instr raw_instr = - Pfedit.mutate (do_instr raw_instr) - -(* - -(* STUFF FOR ITERATED RELATIONS *) -let decompose_bin_app t= - let hd,args = destApp - -let identify_transitivity_lemma c = - let varx,tx,c1 = destProd c in - let vary,ty,c2 = destProd (pop c1) in - let varz,tz,c3 = destProd (pop c2) in - let _,p1,c4 = destProd (pop c3) in - let _,lp2,lp3 = destProd (pop c4) in - let p2=pop lp2 in - let p3=pop lp3 in -*) - diff --git a/tactics/decl_proof_instr.mli b/tactics/decl_proof_instr.mli deleted file mode 100644 index 1cfcfedf14..0000000000 --- a/tactics/decl_proof_instr.mli +++ /dev/null @@ -1,119 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit -val return_from_tactic_mode: unit -> unit - -val register_automation_tac: tactic -> unit - -val automation_tac : tactic - -val daimon_subtree: pftreestate -> pftreestate - -val concl_refiner: - Termops.meta_type_map -> constr -> Proof_type.goal sigma -> constr - -val do_instr: Decl_expr.raw_proof_instr -> pftreestate -> pftreestate -val proof_instr: Decl_expr.raw_proof_instr -> unit - -val tcl_change_info : Decl_mode.pm_info -> tactic - -val mark_proof_tree_as_done : Proof_type.proof_tree -> Proof_type.proof_tree - -val mark_as_done : pftreestate -> pftreestate - -val execute_cases : - Names.name -> - Decl_mode.per_info -> - (Term.constr -> Proof_type.tactic) -> - (Names.Idset.elt * (Term.constr option * Term.constr list) list) list -> - Term.constr list -> int -> Decl_mode.split_tree -> Proof_type.tactic - -val tree_of_pats : - identifier * (int * int) -> (Rawterm.cases_pattern*recpath) list list -> - split_tree - -val add_branch : - identifier * (int * int) -> (Rawterm.cases_pattern*recpath) list list -> - split_tree -> split_tree - -val append_branch : - identifier *(int * int) -> int -> (Rawterm.cases_pattern*recpath) list list -> - (Names.Idset.t * Decl_mode.split_tree) option -> - (Names.Idset.t * Decl_mode.split_tree) option - -val append_tree : - identifier * (int * int) -> int -> (Rawterm.cases_pattern*recpath) list list -> - split_tree -> split_tree - -val build_dep_clause : Term.types Decl_expr.statement list -> - Decl_expr.proof_pattern -> - Decl_mode.per_info -> - (Term.types Decl_expr.statement, Term.types Decl_expr.or_thesis) - Decl_expr.hyp list -> Proof_type.goal Tacmach.sigma -> Term.types - -val register_dep_subcase : - Names.identifier * (int * int) -> - Environ.env -> - Decl_mode.per_info -> - Rawterm.cases_pattern -> Decl_mode.elim_kind -> Decl_mode.elim_kind - -val thesis_for : Term.constr -> - Term.constr -> Decl_mode.per_info -> Environ.env -> Term.constr - -val close_previous_case : pftreestate -> pftreestate - -val pop_stacks : - (Names.identifier * - (Term.constr option * Term.constr list) list) list -> - (Names.identifier * - (Term.constr option * Term.constr list) list) list - -val push_head : Term.constr -> - Names.Idset.t -> - (Names.identifier * - (Term.constr option * Term.constr list) list) list -> - (Names.identifier * - (Term.constr option * Term.constr list) list) list - -val push_arg : Term.constr -> - (Names.identifier * - (Term.constr option * Term.constr list) list) list -> - (Names.identifier * - (Term.constr option * Term.constr list) list) list - -val hrec_for: - Names.identifier -> - Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> - Names.identifier -> Term.constr - -val consider_match : - bool -> - (Names.Idset.elt*bool) list -> - Names.Idset.elt list -> - (Term.types Decl_expr.statement, Term.types) Decl_expr.hyp list -> - Proof_type.tactic - -val init_tree: - Names.Idset.t -> - Names.inductive -> - int option * Declarations.wf_paths -> - (int -> - (int option * Declarations.recarg Rtree.t) array -> - (Names.Idset.t * Decl_mode.split_tree) option) -> - Decl_mode.split_tree - -val set_refine : (Evd.open_constr -> Proof_type.tactic) -> unit diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index b0fef2b71b..49af8b40ea 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -19,7 +19,6 @@ open Termops open Sign open Reduction open Proof_type -open Proof_trees open Declarations open Tacticals open Tacmach @@ -170,7 +169,7 @@ let find_first_goal gls = type search_state = { depth : int; (*r depth of search before failing *) - tacres : goal list sigma * validation; + tacres : goal list sigma; last_tactic : std_ppcmds; dblist : Auto.hint_db list; localdb : Auto.hint_db list } @@ -179,7 +178,7 @@ module SearchProblem = struct type state = search_state - let success s = (sig_it (fst s.tacres)) = [] + let success s = (sig_it s.tacres) = [] let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) @@ -187,7 +186,7 @@ module SearchProblem = struct let evars = Evarutil.nf_evars (Refiner.project gls) in prlist (pr_ev evars) (sig_it gls) - let filter_tactics (glls,v) l = + let filter_tactics glls l = (* let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) (* let evars = Evarutil.nf_evars (Refiner.project glls) in *) (* msg (str"Goal:" ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n"); *) @@ -195,11 +194,10 @@ module SearchProblem = struct | [] -> [] | (tac,pptac) :: tacl -> try - let (lgls,ptl) = apply_tac_list tac glls in - let v' p = v (ptl p) in + let lgls = apply_tac_list tac glls in (* let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) (* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) - ((lgls,v'),pptac) :: aux tacl + (lgls,pptac) :: aux tacl with e -> Refiner.catch_failerror e; aux tacl in aux l @@ -207,14 +205,14 @@ module SearchProblem = struct number of remaining goals. *) let compare s s' = let d = s'.depth - s.depth in - let nbgoals s = List.length (sig_it (fst s.tacres)) in + let nbgoals s = List.length (sig_it s.tacres) in if d <> 0 then d else nbgoals s - nbgoals s' let branching s = if s.depth = 0 then [] else - let lg = fst s.tacres in + let lg = s.tacres in let nbgl = List.length (sig_it lg) in assert (nbgl > 0); let g = find_first_goal lg in @@ -232,7 +230,7 @@ module SearchProblem = struct in let intro_tac = List.map - (fun ((lgls,_) as res,pp) -> + (fun (lgls as res,pp) -> let g' = first_goal lgls in let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') @@ -248,7 +246,7 @@ module SearchProblem = struct filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) in List.map - (fun ((lgls,_) as res, pp) -> + (fun (lgls as res, pp) -> let nbgl' = List.length (sig_it lgls) in if nbgl' < nbgl then { depth = s.depth; tacres = res; last_tactic = pp; diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4 index 0d1699b1cf..d5e4ca17d7 100644 --- a/tactics/eqdecide.ml4 +++ b/tactics/eqdecide.ml4 @@ -29,7 +29,6 @@ open Auto open Pattern open Matching open Hipattern -open Proof_trees open Proof_type open Tacmach open Coqlib diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml index ad392c7d84..906c32c57a 100644 --- a/tactics/evar_tactics.ml +++ b/tactics/evar_tactics.ml @@ -33,9 +33,9 @@ let instantiate n (ist,rawc) ido gl = let sigma = gl.sigma in let evl = match ido with - ConclLocation () -> evar_list sigma gl.it.evar_concl + ConclLocation () -> evar_list sigma (pf_concl gl) | HypLocation (id,hloc) -> - let decl = Environ.lookup_named_val id gl.it.evar_hyps in + let decl = Environ.lookup_named_val id (Goal.V82.hyps sigma (sig_it gl)) in match hloc with InHyp -> (match decl with diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index 9aec0e0914..b6112c34fb 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -21,7 +21,6 @@ open Reductionops open Inductiveops open Evd open Environ -open Proof_trees open Clenv open Pattern open Matching diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index d98d2a2b36..9b04a2cd27 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -15,7 +15,6 @@ open Term open Sign open Evd open Pattern -open Proof_trees open Coqlib (*i*) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index d0f6e82263..395a7c206e 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -24,7 +24,6 @@ open Entries open Inductiveops open Environ open Tacmach -open Proof_trees open Proof_type open Pfedit open Evar_refiner @@ -217,29 +216,31 @@ let inversion_scheme env sigma t sort dep_option inv_op = errorlabstrm "lemma_inversion" (str"Computed inversion goal was not closed in initial signature."); *) - let invSign = named_context_val invEnv in - let pfs = mk_pftreestate (mk_goal invSign invGoal None) in - let pfs = solve_pftreestate (tclTHEN intro (onLastHypId inv_op)) pfs in - let (pfterm,meta_types) = extract_open_pftreestate pfs in + let pf = Proof.start [invEnv,invGoal] in + Proof.run_tactic env (Proofview.V82.tactic (tclTHEN intro (onLastHypId inv_op))) pf; + let pfterm = List.hd (Proof.partial_proof pf) in let global_named_context = Global.named_context () in - let ownSign = + let ownSign = ref begin fold_named_context (fun env (id,_,_ as d) sign -> if mem_named_context id global_named_context then sign else add_named_decl d sign) invEnv ~init:empty_named_context - in - let (_,ownSign,mvb) = - List.fold_left - (fun (avoid,sign,mvb) (mv,mvty) -> - let h = next_ident_away (id_of_string "H") avoid in - (h::avoid, add_named_decl (h,None,mvty) sign, (mv,mkVar h)::mvb)) - (ids_of_context invEnv, ownSign, []) - meta_types + end in + let avoid = ref [] in + let { sigma=sigma } = Proof.V82.subgoals pf in + let rec fill_holes c = + match kind_of_term c with + | Evar (e,_) -> + let h = next_ident_away (id_of_string "H") !avoid in + let ty = (Evd.find sigma e).evar_concl in + avoid := h::!avoid; + ownSign := add_named_decl (h,None,ty) !ownSign; + mkVar h + | _ -> map_constr fill_holes c in let invProof = - it_mkNamedLambda_or_LetIn - (local_strong (fun _ -> whd_meta mvb) Evd.empty pfterm) ownSign + it_mkNamedLambda_or_LetIn (fill_holes pfterm) !ownSign in invProof @@ -255,26 +256,17 @@ let add_inversion_lemma name env sigma t sort dep inv_op = IsProof Lemma) in () -(* open Pfedit *) - (* inv_op = Inv (derives de complete inv. lemma) * inv_op = InvNoThining (derives de semi inversion lemma) *) let inversion_lemma_from_goal n na (loc,id) sort dep_option inv_op = let pts = get_pftreestate() in - let gl = nth_goal_of_pftreestate n pts in + let { it=gls ; sigma=sigma } = Proof.V82.subgoals pts in + let gl = { it = List.nth gls (n-1) ; sigma=sigma } in let t = try pf_get_hyp_typ gl id with Not_found -> Pretype_errors.error_var_not_found_loc loc id in let env = pf_env gl and sigma = project gl in -(* Pourquoi ??? - let fv = global_vars env t in - let thin_ids = thin_ids (hyps,fv) in - if not(list_subset thin_ids fv) then - errorlabstrm "lemma_inversion" - (str"Cannot compute lemma inversion when there are" ++ spc () ++ - str"free variables in the types of an inductive" ++ spc () ++ - str"which are not free in its instance."); *) add_inversion_lemma na env sigma t sort dep_option inv_op let add_inversion_lemma_exn na com comsort bool tac = diff --git a/tactics/refine.ml b/tactics/refine.ml index 67a73b9be5..cb6cb961f4 100644 --- a/tactics/refine.ml +++ b/tactics/refine.ml @@ -382,5 +382,3 @@ let refine (evd,c) gl = complicated to update meta types when passing through a binder *) let th = compute_metamap (pf_env gl) evd c in tclTHEN (Refiner.tclEVARS evd) (tcc_aux [] th) gl - -let _ = Decl_proof_instr.set_refine refine (* dirty trick to solve circular dependency *) diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4 index e08e5e9ede..1af2d33988 100644 --- a/tactics/rewrite.ml4 +++ b/tactics/rewrite.ml4 @@ -21,7 +21,6 @@ open Termops open Sign open Reduction open Proof_type -open Proof_trees open Declarations open Tacticals open Tacmach @@ -569,7 +568,7 @@ let apply_rule hypinfo loccs : strategy = if eq_constr t c2 then Some None else let goalevars = Evd.evar_merge (fst evars) - (Evd.undefined_evars (Evarutil.nf_evar_map env'.evd)) + (Evd.undefined_evars env'.evd) in let res = { rew_car = ty; rew_from = c1; rew_to = c2; rew_prf = RewPrf (rel, prf); rew_evars = goalevars, snd evars } @@ -908,8 +907,8 @@ module Strategies = let hints (db : string) : strategy = fun env sigma t ty cstr evars -> - let rules = Autorewrite.find_matches db t in - lemmas (List.map (fun hint -> (inj_open hint.Autorewrite.rew_lemma, hint.Autorewrite.rew_l2r)) rules) + let rules = Autorewrite.find_matches db t in + lemmas (List.map (fun hint -> (inj_open hint.Autorewrite.rew_lemma, hint.Autorewrite.rew_l2r)) rules) env sigma t ty cstr evars let reduce (r : Redexpr.red_expr) : strategy = @@ -1051,8 +1050,8 @@ let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl = change_in_concl None newt) in let evartac = - if not (undef = Evd.empty) then - Refiner.tclEVARS undef + if not (Evd.is_empty undef) then + Refiner.tclEVARS evars else tclIDTAC in tclTHENLIST [evartac; rewtac] gl with @@ -1575,9 +1574,10 @@ let general_s_rewrite cl l2r occs (c,l) ~new_goals gl = let meta = Evarutil.new_meta() in let hypinfo, strat = apply_lemma gl c cl l2r occs in try - tclTHEN - (Refiner.tclEVARS hypinfo.cl.evd) - (cl_rewrite_clause_aux ~abs:hypinfo.abs strat meta cl) gl + tclWEAK_PROGRESS + (tclTHEN + (Refiner.tclEVARS hypinfo.cl.evd) + (cl_rewrite_clause_aux ~abs:hypinfo.abs strat meta cl)) gl with RewriteFailure -> let {l2r=l2r; c1=x; c2=y} = hypinfo in raise (Pretype_errors.PretypeError diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 0e352110a0..6e3957ac05 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -73,7 +73,7 @@ type ltac_type = (* Values for interpretation *) type value = - | VRTactic of (goal list sigma * validation) (* For Match results *) + | VRTactic of (goal list sigma) (* For Match results *) (* Not a true value *) | VFun of ltac_trace * (identifier*value) list * identifier option list * glob_tactic_expr @@ -347,11 +347,6 @@ let vars_of_ist (lfun,_,_,env) = List.fold_left (fun s id -> Idset.add id s) (vars_of_env env) lfun -let get_current_context () = - try Pfedit.get_current_goal_context () - with e when Logic.catchable_exception e -> - (Evd.empty, Global.env()) - let strict_check = ref false let adjust_loc loc = if !strict_check then dloc else loc @@ -1794,11 +1789,11 @@ let mk_int_or_var_value ist c = VInteger (interp_int_or_var ist c) let pack_sigma (sigma,c) = {it=c;sigma=sigma} -let extend_gl_hyps gl sign = - { gl with - it = { gl.it with - evar_hyps = - List.fold_right Environ.push_named_context_val sign gl.it.evar_hyps } } +let extend_gl_hyps { it=gl ; sigma=sigma } sign = + let hyps = Goal.V82.hyps sigma gl in + let new_hyps = List.fold_right Environ.push_named_context_val sign hyps in + (* spiwack: (2010/01/13) if a bug was reintroduced in [change] in is probably here *) + Goal.V82.new_goal_with sigma gl new_hyps (* Interprets an l-tac expression into a value *) let rec val_interp ist gl (tac:glob_tactic_expr) = @@ -1988,6 +1983,8 @@ and interp_letin ist gl llc u = (* Interprets the Match Context expressions *) and interp_match_goal ist goal lz lr lmr = + let (gl,sigma) = Goal.V82.nf_evar (project goal) (sig_it goal) in + let goal = { it = gl ; sigma = sigma } in let hyps = pf_hyps goal in let hyps = if lr then List.rev hyps else hyps in let concl = pf_concl goal in diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index fe4e9f6aab..71ee29f8cc 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -25,7 +25,7 @@ open Redexpr (* Values for interpretation *) type value = - | VRTactic of (goal list sigma * validation) + | VRTactic of (goal list sigma) | VFun of ltac_trace * (identifier*value) list * identifier option list * glob_tactic_expr | VVoid diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 332855052d..045f70c61b 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -61,8 +61,8 @@ let tclAT_LEAST_ONCE = Refiner.tclAT_LEAST_ONCE let tclFAIL = Refiner.tclFAIL let tclFAIL_lazy = Refiner.tclFAIL_lazy let tclDO = Refiner.tclDO -let tclPROGRESS = Refiner.tclPROGRESS let tclWEAK_PROGRESS = Refiner.tclWEAK_PROGRESS +let tclPROGRESS = Refiner.tclPROGRESS let tclNOTSAMEGOAL = Refiner.tclNOTSAMEGOAL let tclTHENTRY = Refiner.tclTHENTRY let tclIFTHENELSE = Refiner.tclIFTHENELSE diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index b9c8ab928b..3dd73c92c3 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -55,8 +55,8 @@ val tclAT_LEAST_ONCE : tactic -> tactic val tclFAIL : int -> std_ppcmds -> tactic val tclFAIL_lazy : int -> std_ppcmds Lazy.t -> tactic val tclDO : int -> tactic -> tactic -val tclPROGRESS : tactic -> tactic val tclWEAK_PROGRESS : tactic -> tactic +val tclPROGRESS : tactic -> tactic val tclNOTSAMEGOAL : tactic -> tactic val tclTHENTRY : tactic -> tactic -> tactic val tclMAP : ('a -> tactic) -> 'a list -> tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 41fab4e716..e6201aad9d 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -27,7 +27,6 @@ open Pfedit open Tacred open Rawterm open Tacmach -open Proof_trees open Proof_type open Logic open Evar_refiner @@ -516,8 +515,8 @@ let intro_move idopt hto = match idopt with | Some id -> intro_gen dloc (IntroMustBe id) hto true false let pf_lookup_hypothesis_as_renamed env ccl = function - | AnonHyp n -> pf_lookup_index_as_renamed env ccl n - | NamedHyp id -> pf_lookup_name_as_displayed env ccl id + | AnonHyp n -> Detyping.lookup_index_as_renamed env ccl n + | NamedHyp id -> Detyping.lookup_name_as_displayed env ccl id let pf_lookup_hypothesis_as_renamed_gen red h gl = let env = pf_env gl in @@ -614,7 +613,7 @@ let bring_hyps hyps = let resolve_classes gl = let env = pf_env gl and evd = project gl in - if evd = Evd.empty then tclIDTAC gl + if Evd.is_empty evd then tclIDTAC gl else let evd' = Typeclasses.resolve_typeclasses env (Evd.create_evar_defs evd) in (tclTHEN (tclEVARS evd') tclNORMEVAR) gl diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index b885b15243..333d6a3a21 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -19,6 +19,4 @@ Leminv Tacinterp Evar_tactics Autorewrite -Decl_interp -Decl_proof_instr Tactic_option diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 0d9c9ae9d5..a8193ef3c8 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -393,7 +393,7 @@ Program Instance subrelation_partial_order : Next Obligation. Proof. - unfold relation_equivalence in *. firstorder. + unfold relation_equivalence in *. compute; firstorder. Qed. Typeclasses Opaque arrows predicate_implication predicate_equivalence diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 685c724703..45b949716c 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -18,9 +18,11 @@ Require Export Coq.Init.Tactics. (* Initially available plugins (+ nat_syntax_plugin loaded in Datatypes) *) Declare ML Module "extraction_plugin". +Declare ML Module "decl_mode_plugin". Declare ML Module "cc_plugin". Declare ML Module "ground_plugin". Declare ML Module "dp_plugin". Declare ML Module "recdef_plugin". Declare ML Module "subtac_plugin". Declare ML Module "xml_plugin". +Global Set Default Proof Mode "Classic". diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v index ee12c6a8db..e2c6232013 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v @@ -1097,7 +1097,7 @@ intros x; case x; simpl ww_is_even. rewrite wwB_wBwB; rewrite Zpower_2. apply Zmult_le_compat_r; auto with zarith. case (spec_to_Z w4);auto with zarith. - Qed. +Qed. Lemma spec_ww_is_zero: forall x, if ww_is_zero x then [[x]] = 0 else 0 < [[x]]. diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index 4fd2a8f0a2..e2e5b563f2 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -2387,7 +2387,7 @@ Section Int31_Specs. replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring. rewrite <-Hil2. change (-1 * 2 ^ Z_of_nat size) with (-base); ring. - Qed. +Qed. (** [iszero] *) diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index 6f7645841c..d187941d20 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -304,8 +304,10 @@ Ltac refine_hyp c := possibly using [program_simplify] to use standard goal-cleaning tactics. *) Ltac program_simplify := - simpl in |- *; intros ; destruct_all_rec_calls ; repeat (destruct_conjs; simpl proj1_sig in *); - subst*; autoinjections ; try discriminates ; +(* arnaud: enlever la première ligne en faveur de la suite. *) +simpl ; intros ; destruct_conjs ; simpl proj1_sig in * ; subst* ; autoinjections ; try discriminates ; +(* arnaud: restore: simpl in |- *; intros ; destruct_all_rec_calls ; repeat (destruct_conjs; simpl proj1_sig in * ); + subst*; autoinjections ; try discriminates ;*) try (solve [ red ; intros ; destruct_conjs ; autoinjections ; discriminates ]). Ltac program_solve_wf := diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v index ae2c3d77f8..9fd6e00882 100644 --- a/theories/Reals/RiemannInt.v +++ b/theories/Reals/RiemannInt.v @@ -2242,7 +2242,7 @@ Proof. unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro. eapply StepFun_P17. apply StepFun_P1. - simpl in |- *; apply StepFun_P1. + simpl in |- *; apply StepFun_P1. apply Ropp_eq_compat; eapply StepFun_P17. apply StepFun_P1. simpl in |- *; apply StepFun_P1. diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 0e66c43c3b..d8c7326a9e 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -551,7 +551,7 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). Ci a1 ... an = Ci b1 ... bn replace bi with ai; auto || replace bi with ai by apply typeofbi_prod ; auto *) - fun gls-> let gl = (gls.Evd.it).Evd.evar_concl in + fun gls-> let gl = pf_concl gls in match (kind_of_term gl) with | App (c,ca) -> ( match (kind_of_term c) with @@ -674,7 +674,7 @@ let compute_lb_tact lb_scheme_key ind lnamesparrec nparrec gsig = tclTHENSEQ [apply (andb_true_intro()); simplest_split ;Auto.default_auto ] ); - fun gls -> let gl = (gls.Evd.it).Evd.evar_concl in + fun gls -> let gl = pf_concl gls in (* assume the goal to be eq (eq_type ...) = true *) match (kind_of_term gl) with | App(c,ca) -> (match (kind_of_term ca.(1)) with diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 01e83b1ad0..0fb9a33b2b 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -512,7 +512,14 @@ let explain_no_instance env (_,id) l = str "applied to arguments" ++ spc () ++ prlist_with_sep pr_spc (pr_lconstr_env env) l +let undefined_evars evm = + Evd.fold (fun ev evi undef -> + if evi.evar_body = Evar_empty then + Evd.add undef ev (Evarutil.nf_evar_info evm evi) + else undef) evm Evd.empty + let pr_constraints printenv env evm = + let evm = undefined_evars evm in let l = Evd.to_list evm in let (ev, evi) = List.hd l in if List.for_all (fun (ev', evi') -> diff --git a/toplevel/lemmas.mli b/toplevel/lemmas.mli index 5d4f014a36..f4e9f6f587 100644 --- a/toplevel/lemmas.mli +++ b/toplevel/lemmas.mli @@ -36,7 +36,7 @@ val start_proof_with_initialization : declaration_hook -> unit (* A hook the next three functions pass to cook_proof *) -val set_save_hook : (Refiner.pftreestate -> unit) -> unit +val set_save_hook : (Proof.proof -> unit) -> unit (*s [save_named b] saves the current completed proof under the name it was started; boolean [b] tells if the theorem is declared opaque; it diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 886f4033d8..36f1e96e94 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -19,8 +19,6 @@ open Nameops open Term open Pfedit open Tacmach -open Proof_trees -open Decl_mode open Constrintern open Prettyp open Printer @@ -66,52 +64,34 @@ let cl_of_qualid = function (* "Show" commands *) let show_proof () = - let pts = get_pftreestate () in - let cursor = cursor_of_pftreestate pts in - let evc = evc_of_pftreestate pts in - let (pfterm,meta_types) = extract_open_pftreestate pts in - msgnl (str"LOC: " ++ - prlist_with_sep pr_spc pr_int (List.rev cursor) ++ fnl () ++ - str"Subgoals" ++ fnl () ++ - prlist (fun (mv,ty) -> Nameops.pr_meta mv ++ str" -> " ++ - pr_ltype ty ++ fnl ()) - meta_types - ++ str"Proof: " ++ pr_lconstr (Evarutil.nf_evar evc pfterm)) + (* spiwack: this would probably be cooler with a bit of polishing. *) + let p = Proof_global.give_me_the_proof () in + let pprf = Proof.partial_proof p in + msgnl (Util.prlist_with_sep Pp.fnl Printer.pr_constr pprf) let show_node () = - let pts = get_pftreestate () in - let pf = proof_of_pftreestate pts - and cursor = cursor_of_pftreestate pts in - msgnl (prlist_with_sep pr_spc pr_int (List.rev cursor) ++ fnl () ++ - pr_goal (goal_of_proof pf) ++ fnl () ++ - (match pf.Proof_type.ref with - | None -> (str"BY ") - | Some(r,spfl) -> - (str"BY " ++ pr_rule r ++ fnl () ++ - str" " ++ - hov 0 (prlist_with_sep pr_fnl pr_goal - (List.map goal_of_proof spfl))))) + (* spiwack: I'm have little clue what this function used to do. I deactivated it, + could, possibly, be cleaned away. (Feb. 2010) *) + () let show_script () = - let pts = get_pftreestate () in - let pf = proof_of_pftreestate pts - and evc = evc_of_pftreestate pts in - msgnl_with !Pp_control.deep_ft (print_treescript evc pf) + (* spiwack: show_script is currently not working *) + () let show_thesis () = msgnl (anomaly "TODO" ) let show_top_evars () = + (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) let pfts = get_pftreestate () in - let gls = top_goal_of_pftreestate pfts in - let sigma = project gls in + let gls = Proof.V82.subgoals pfts in + let sigma = gls.Evd.sigma in msg (pr_evars_int 1 (Evarutil.non_instantiated sigma)) + let show_prooftree () = - let pts = get_pftreestate () in - let pf = proof_of_pftreestate pts - and evc = evc_of_pftreestate pts in - msg (print_proof evc (Global.named_context()) pf) + (* Spiwack: proof tree is currently not working *) + () let print_subgoals () = if_verbose (fun () -> msg (pr_open_subgoals ())) () @@ -119,7 +99,8 @@ let print_subgoals () = if_verbose (fun () -> msg (pr_open_subgoals ())) () let show_intro all = let pf = get_pftreestate() in - let gl = nth_goal_of_pftreestate 1 pf in + let {Evd.it=gls ; sigma=sigma} = Proof.V82.subgoals pf in + let gl = {Evd.it=List.hd gls ; sigma = sigma} in let l,_= decompose_prod_assum (strip_outer_cast (pf_concl gl)) in if all then @@ -349,14 +330,10 @@ let vernac_end_proof = function the theories [??] *) let vernac_exact_proof c = - let pfs = top_of_tree (get_pftreestate()) in - let pf = proof_of_pftreestate pfs in - if (is_leaf_proof pf) then begin - by (Tactics.exact_proof c); - save_named true end - else - errorlabstrm "Vernacentries.ExactProof" - (strbrk "Command 'Proof ...' can only be used at the beginning of the proof.") + (* spiwack: for simplicity I do not enforce that "Proof proof_term" is + called only at the begining of a proof. *) + by (Tactics.exact_proof c); + save_named true let vernac_assumption kind l nl= if Pfedit.refining () then @@ -626,24 +603,61 @@ let vernac_declare_class id = (***********) (* Solving *) -let vernac_solve n tcom b = + +let command_focus = Proof.new_focus_kind () +let focus_command_cond = Proof.no_cond command_focus + +(* Gestion of bullets. *) +open Store.Field +(* spiwack: we need only one focus kind as we keep a stack of (distinct!) bullets *) +let bullet_kind = Proof.new_focus_kind () +let bullet_cond = Proof.done_cond bullet_kind +let (get_bullets,set_bullets) = + let bullets = Store.field () in + ( begin fun pr -> Option.default [] (bullets.get (Proof.get_proof_info pr)) end , + begin fun bs pr -> Proof.set_proof_info (bullets.set bs (Proof.get_proof_info pr)) pr end ) +let has_bullet bul pr = + let rec has_bullet = function + | b'::_ when bul=b' -> true + | _::l -> has_bullet l + | [] -> false + in + has_bullet (get_bullets pr) +(* precondition: the stack is not empty *) +let pop_bullet pr = + match get_bullets pr with + | b::stk -> Proof.unfocus bullet_kind pr ; + set_bullets stk pr ; + b + | [] -> Util.anomaly "Tried to pop bullet from an empty stack" +let push_bullet b pr = + Proof.focus bullet_cond 1 pr ; + set_bullets (b::get_bullets pr) pr + +let put_bullet p bul = + if has_bullet bul p then + begin + while bul <> pop_bullet p do () done; + push_bullet bul p + end + else + push_bullet bul p + +let vernac_solve n bullet tcom b = if not (refining ()) then error "Unknown command of the non proof-editing mode."; - Decl_mode.check_not_proof_mode "Unknown proof instruction"; - begin - if b then - solve_nth n (Tacinterp.hide_interp tcom (get_end_tac ())) - else solve_nth n (Tacinterp.hide_interp tcom None) - end; + let p = Proof_global.give_me_the_proof () in + Option.iter (put_bullet p) bullet ; + solve_nth n (Tacinterp.hide_interp tcom None) ~with_end_tac:b; (* in case a strict subtree was completed, go back to the top of the prooftree *) - if subtree_solved () then begin - Flags.if_verbose msgnl (str "Subgoal proved"); - make_focus 0; - reset_top_of_script () - end; + begin try while Proof.no_focused_goal p do + Proof.unfocus command_focus p + done + with Util.UserError _ -> () end; print_subgoals(); if !pcoq <> None then (Option.get !pcoq).solve n + (* A command which should be a tactic. It has been added by Christine to patch an error in the design of the proof @@ -659,32 +673,6 @@ let vernac_set_end_tac tac = if tac <> (Tacexpr.TacId []) then set_end_tac (Tacinterp.interp tac) else () (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) -(***********************) -(* Proof Language Mode *) - -let vernac_decl_proof () = - check_not_proof_mode "Already in Proof Mode"; - if tree_solved () then - error "Nothing left to prove here." - else - begin - Decl_proof_instr.go_to_proof_mode (); - print_subgoals () - end - -let vernac_return () = - match get_current_mode () with - Mode_tactic -> - Decl_proof_instr.return_from_tactic_mode (); - print_subgoals () - | Mode_proof -> - error "\"return\" is only used after \"escape\"." - | Mode_none -> - error "There is no proof to end." - -let vernac_proof_instr instr = - Decl_proof_instr.proof_instr instr; - print_subgoals () (*****************************) (* Auxiliary file management *) @@ -825,14 +813,6 @@ let _ = optread = Impargs.is_contextual_implicit_args; optwrite = Impargs.make_contextual_implicit_args } -(* let _ = *) -(* declare_bool_option *) -(* { optsync = true; *) -(* optname = "forceable implicit arguments"; *) -(* optkey = ["Forceable";"Implicit")); *) -(* optread = Impargs.is_forceable_implicit_args; *) -(* optwrite = Impargs.make_forceable_implicit_args } *) - let _ = declare_bool_option { optsync = true; @@ -1223,41 +1203,56 @@ let vernac_backtrack snum pnum naborts = vernac_backto snum; Pp.flush_all(); (* there may be no proof in progress, even if no abort *) - (try print_subgoals () with UserError _ -> ()) + (try print_subgoals () with Proof_global.NoCurrentProof | UserError _ -> ()) let vernac_focus gln = - check_not_proof_mode "No focussing or Unfocussing in Proof Mode."; + let p = Proof_global.give_me_the_proof () in match gln with - | None -> traverse_nth_goal 1; print_subgoals () - | Some n -> traverse_nth_goal n; print_subgoals () + | None -> Proof.focus focus_command_cond 1 p; print_subgoals () + | Some n -> Proof.focus focus_command_cond n p; print_subgoals () + - (* Reset the focus to the top of the tree *) + (* Unfocuses one step in the focus stack. *) let vernac_unfocus () = - check_not_proof_mode "No focussing or Unfocussing in Proof Mode."; - make_focus 0; reset_top_of_script (); print_subgoals () - -let vernac_go = function - | GoTo n -> Pfedit.traverse n;show_node() - | GoTop -> Pfedit.reset_top_of_tree ();show_node() - | GoNext -> Pfedit.traverse_next_unproven ();show_node() - | GoPrev -> Pfedit.traverse_prev_unproven ();show_node() - -let apply_subproof f occ = - let pts = get_pftreestate() in - let evc = evc_of_pftreestate pts in - let rec aux pts = function - | [] -> pts - | (n::l) -> aux (Tacmach.traverse n pts) occ in - let pts = aux pts (occ@[-1]) in - let pf = proof_of_pftreestate pts in - f evc (Global.named_context()) pf + let p = Proof_global.give_me_the_proof () in + Proof.unfocus command_focus p; print_subgoals () + +(* BeginSubproof / EndSubproof. + BeginSubproof (vernac_subproof) focuses on the first goal, or the goal + given as argument. + EndSubproof (vernac_end_subproof) unfocuses from a BeginSubproof, provided + that the proof of the goal has been completed. +*) +let subproof_kind = Proof.new_focus_kind () +let subproof_cond = Proof.done_cond subproof_kind + +let vernac_subproof gln = + let p = Proof_global.give_me_the_proof () in + begin match gln with + | None -> Proof.focus subproof_cond 1 p + | Some n -> Proof.focus subproof_cond n p + end ; + print_subgoals () + +let vernac_end_subproof () = + let p = Proof_global.give_me_the_proof () in + Proof.unfocus subproof_kind p ; print_subgoals () + +let vernac_go _ = + (* spiwack: don't know what it's supposed to do. Undocumented. + Deactivated and candidate for removal. (Feb. 2010) *) + () let explain_proof occ = - msg (apply_subproof (fun evd _ -> print_treescript evd) occ) + (* spiwack: don't know what it's supposed to do. Undocumented. + Deactivated and candidate for removal. (Feb. 2010) *) + () let explain_tree occ = - msg (apply_subproof print_proof occ) + (* spiwack: don't know what it's supposed to do. Undocumented. + Deactivated and candidate for removeal. (Feb. 2010) *) + () let vernac_show = function | ShowGoal nopt -> @@ -1285,11 +1280,11 @@ let vernac_show = function let vernac_check_guard () = let pts = get_pftreestate () in - let pf = proof_of_pftreestate pts in - let (pfterm,_) = extract_open_pftreestate pts in + let pfterm = List.hd (Proof.partial_proof pts) in let message = try - Inductiveops.control_only_guard (Evd.evar_env (goal_of_proof pf)) + let { Evd.it=gl ; sigma=sigma } = Proof.V82.top_goal pts in + Inductiveops.control_only_guard (Goal.V82.env sigma gl) pfterm; (str "The condition holds up to here") with UserError(_,s) -> @@ -1352,17 +1347,9 @@ let interp c = match c with | VernacDeclareClass id -> vernac_declare_class id (* Solving *) - | VernacSolve (n,tac,b) -> vernac_solve n tac b + | VernacSolve (n,bullet,tac,b) -> vernac_solve n bullet tac b | VernacSolveExistential (n,c) -> vernac_solve_existential n c - (* MMode *) - - | VernacDeclProof -> vernac_decl_proof () - | VernacReturn -> vernac_return () - | VernacProofInstr stp -> vernac_proof_instr stp - - (* /MMode *) - (* Auxiliary file and library management *) | VernacRequireFrom (exp,spec,f) -> vernac_require_from exp spec f | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias @@ -1418,10 +1405,13 @@ let interp c = match c with | VernacBacktrack (snum,pnum,naborts) -> vernac_backtrack snum pnum naborts | VernacFocus n -> vernac_focus n | VernacUnfocus -> vernac_unfocus () + | VernacSubproof n -> vernac_subproof n + | VernacEndSubproof -> vernac_end_subproof () | VernacGo g -> vernac_go g | VernacShow s -> vernac_show s | VernacCheckGuard -> vernac_check_guard () | VernacProof tac -> vernac_set_end_tac tac + | VernacProofMode mn -> Proof_global.set_proof_mode mn (* Toplevel control *) | VernacToplevelControl e -> raise e diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli index 44e8b7ab46..58df8a9065 100644 --- a/toplevel/vernacentries.mli +++ b/toplevel/vernacentries.mli @@ -55,3 +55,14 @@ val abort_refine : ('a -> unit) -> 'a -> unit;; val interp : Vernacexpr.vernac_expr -> unit val vernac_reset_name : identifier Util.located -> unit + +(* Print subgoals when the verbose flag is on. Meant to be used inside + vernac commands from plugins. *) +val print_subgoals : unit -> unit + + +(* Handles focusing/defocusing with bullets: + - If this bullet follows another one of its kind, defocuses then focuses + (which fails if the focused subproof is not complete). + - If it is the first bullet of its kind, then focuses a new subproof. *) +val put_bullet : Proof.proof -> bullet -> unit diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml index 0db000a485..e216f25203 100644 --- a/toplevel/vernacexpr.ml +++ b/toplevel/vernacexpr.ml @@ -190,6 +190,11 @@ type syntax_modifier = | SetOnlyParsing | SetFormat of string located +type bullet = + | Dash + | Star + | Plus + type proof_end = | Admitted | Proved of opacity_flag * (lident * theorem_kind option) option @@ -274,16 +279,9 @@ type vernac_expr = (* Solving *) - | VernacSolve of int * raw_tactic_expr * bool + | VernacSolve of int * bullet option * raw_tactic_expr * bool | VernacSolveExistential of int * constr_expr - (* Proof Mode *) - - | VernacDeclProof - | VernacReturn - | VernacProofInstr of Decl_expr.raw_proof_instr - - (* Auxiliary file and library management *) | VernacRequireFrom of export_flag option * specif_flag option * string | VernacAddLoadPath of rec_flag * string * dir_path option @@ -343,10 +341,13 @@ type vernac_expr = | VernacBacktrack of int*int*int | VernacFocus of int option | VernacUnfocus + | VernacSubproof of int option + | VernacEndSubproof | VernacGo of goable | VernacShow of showable | VernacCheckGuard | VernacProof of raw_tactic_expr + | VernacProofMode of string (* Toplevel control *) | VernacToplevelControl of exn diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4 index 98a79a9ce2..9d4b5ec0cf 100644 --- a/toplevel/whelp.ml4 +++ b/toplevel/whelp.ml4 @@ -196,7 +196,8 @@ let whelp_elim ind = send_whelp "elim" (make_string uri_of_global (IndRef ind)) let on_goal f = - let gls = nth_goal_of_pftreestate 1 (get_pftreestate ()) in + let { Evd.it=goals ; sigma=sigma } = Proof.V82.subgoals (get_pftreestate ()) in + let gls = { Evd.it=List.hd goals ; sigma = sigma } in f (it_mkNamedProd_or_LetIn (pf_concl gls) (pf_hyps gls)) type whelp_request = -- cgit v1.2.3