diff options
128 files changed, 3850 insertions, 2954 deletions
diff --git a/Makefile.common b/Makefile.common index e3a94f56d..4d5e00d25 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 3a31230f1..debc074de 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 e8ec10c5c..8ada6769c 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 b481e9f16..21a690f95 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 87f0c35e6..9b0afc7be 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 4fa0c28f5..5d604a62b 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 e7859962e..68ee15ab7 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 c971ed299..7605df9eb 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 1ffe5eeb5..ff71c3594 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 4191ccdb1..000000000 --- a/lib/bstack.ml +++ /dev/null @@ -1,75 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id$ *) - -(* Queues of a given length *) - -open Util - -(* - size is the count of elements actually in the queue - - depth is the the amount of elements pushed in the queue (and not popped) - in particular, depth >= 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 cef8e1d9e..000000000 --- a/lib/bstack.mli +++ /dev/null @@ -1,22 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id$ i*) - -(* Bounded stacks. If the depth is [None], then there is no depth limit. *) - -type 'a t - -val create : int -> '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 fd870a21b..000000000 --- a/lib/edit.ml +++ /dev/null @@ -1,134 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id$ *) - -open Pp -open Util - -type ('a,'b,'c) t = { - mutable focus : 'a option; - mutable last_focused_stk : 'a list; - buf : ('a, 'b Bstack.t * 'c) Hashtbl.t } - -let empty () = { - focus = None; - last_focused_stk = []; - buf = Hashtbl.create 17 } - -let focus e nd = - if not (Hashtbl.mem e.buf nd) then invalid_arg "Edit.focus"; - begin match e.focus with - | Some foc when foc <> 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 d13d9c6f6..000000000 --- a/lib/edit.mli +++ /dev/null @@ -1,63 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id$ i*) - -(* The type of editors. - * An editor is a finite map, ['a -> '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 1743ce26c..86d29c4be 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 000000000..8f1309531 --- /dev/null +++ b/lib/store.ml @@ -0,0 +1,63 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* $Id$ *) + +(*** This module implements an "untyped store", in this particular case we + see it as an extensible record whose fields are left unspecified. ***) + +(* We give a short implementation of a universal type. This is mostly equivalent + to what is proposed by module Dyn.ml, except that it requires no explicit tag. *) +module type Universal = sig + type t + + type 'a etype = { + put : 'a -> 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 000000000..0caeb2abb --- /dev/null +++ b/lib/store.mli @@ -0,0 +1,27 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* $Id$ *) + +(*** This module implements an "untyped store", in this particular case we + see it as an extensible record whose fields are left unspecified. ***) + +type t + +module Field : sig + type 'a field = { + set : 'a -> 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 023ec0f3c..b5ee1ae60 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 1228b40cf..a45ea9549 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 e73e54e7f..000000000 --- a/parsing/g_decl_mode.ml4 +++ /dev/null @@ -1,252 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) -(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*) - -(* $Id$ *) - - -open Decl_expr -open Names -open Term -open Genarg -open Pcoq - -open Pcoq.Constr -open Pcoq.Tactic -open Pcoq.Vernac_ - -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/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 39e577b88..27ad1e964 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 008a6ac51..db683b9a9 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 248a8ad9a..483538da6 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 3eb27abbb..eed6caea3 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 c0c1817d1..84a08d549 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 7120f72d2..de15d8a7c 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 ed370a995..7ed05ed5c 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/ppvernac.ml b/parsing/ppvernac.ml index 9ebf77adb..dc61aaa26 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 d9dced791..cd07c4e15 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 1797eaf22..2c1586abf 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 c09b3431e..bf554acf6 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 "<Daimon>" | 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"<Your Proof Text here>") 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"<Your Tactic Text here>") 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"<Your Tactic Text here>" - else str"<Your Proof Text here>" - else pr_change pf.goal + str"<Your Proof Text here>" + 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 d46f19c64..96cbeb9a8 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 e8a3094b9..e1997b878 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<None>> l + | "VERNAC"; nt = LIDENT ; "EXTEND"; s = UIDENT; + OPT "|"; l = LIST1 rule SEP "|"; + "END" -> + declare_command loc s <:expr<Some $lid:nt$>> 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 9cc6f9de9..9b5fca4da 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 4e6ea8022..ccfa2a0a7 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/proofs/decl_expr.mli b/plugins/decl_mode/decl_expr.mli index 20a95dabf..20a95dabf 100644 --- a/proofs/decl_expr.mli +++ b/plugins/decl_mode/decl_expr.mli diff --git a/tactics/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index 2b583af40..2b583af40 100644 --- a/tactics/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml diff --git a/tactics/decl_interp.mli b/plugins/decl_mode/decl_interp.mli index bd0859382..bd0859382 100644 --- a/tactics/decl_interp.mli +++ b/plugins/decl_mode/decl_interp.mli diff --git a/proofs/decl_mode.ml b/plugins/decl_mode/decl_mode.ml index ba675327c..90b0085ff 100644 --- a/proofs/decl_mode.ml +++ b/plugins/decl_mode/decl_mode.ml @@ -13,32 +13,17 @@ open Term open Evd open Util + let daimon_flag = ref false let set_daimon_flag () = daimon_flag:=true let clear_daimon_flag () = daimon_flag:=false let get_daimon_flag () = !daimon_flag -type command_mode = - Mode_tactic - | Mode_proof - | Mode_none -let mode_of_pftreestate pts = - let goal = sig_it (Refiner.top_goal_of_pftreestate pts) in - if goal.evar_extra = None then - Mode_tactic - else - Mode_proof -let get_current_mode () = - try - mode_of_pftreestate (Pfedit.get_pftreestate ()) - with _ -> Mode_none - -let check_not_proof_mode str = - if get_current_mode () = Mode_proof then - error str +(* Information associated to goals. *) +open Store.Field type split_tree= Skip_patt of Idset.t * split_tree @@ -72,53 +57,51 @@ type stack_info = type pm_info = { pm_stack : stack_info list} +let info = Store.field () + + +(* Current proof mode *) + +type command_mode = + Mode_tactic + | Mode_proof + | Mode_none + +let mode_of_pftreestate pts = + (* spiwack: it was "top_goal_..." but this should be fine *) + let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in + let goal = List.hd goals in + if info.get (Goal.V82.extra sigma goal) = None then + Mode_tactic + else + Mode_proof + +let get_current_mode () = + try + mode_of_pftreestate (Pfedit.get_pftreestate ()) + with _ -> Mode_none + +let check_not_proof_mode str = + if get_current_mode () = Mode_proof then + error str -let pm_in,pm_out = Dyn.create "pm_info" +let get_info sigma gl= + match info.get (Goal.V82.extra sigma gl) with + | None -> invalid_arg "get_info" + | Some pm -> pm -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 try_get_info sigma gl = + info.get (Goal.V82.extra sigma gl) let get_stack pts = - let info = get_info (sig_it (Refiner.nth_goal_of_pftreestate 1 pts)) in - info.pm_stack + 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 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 { 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 diff --git a/proofs/decl_mode.mli b/plugins/decl_mode/decl_mode.mli index 734dc0442..fe485ce9b 100644 --- a/proofs/decl_mode.mli +++ b/plugins/decl_mode/decl_mode.mli @@ -22,7 +22,7 @@ type command_mode = | Mode_proof | Mode_none -val mode_of_pftreestate : pftreestate -> command_mode +val mode_of_pftreestate : Proof.proof -> command_mode val get_current_mode : unit -> command_mode @@ -61,14 +61,14 @@ type stack_info = type pm_info = {pm_stack : stack_info list } -val pm_in : pm_info -> Dyn.t +val info : pm_info Store.Field.t -val get_info : Proof_type.goal -> pm_info +val get_info : Evd.evar_map -> Proof_type.goal -> pm_info -val get_end_command : pftreestate -> string option +val try_get_info : Evd.evar_map -> Proof_type.goal -> pm_info option -val get_stack : pftreestate -> stack_info list +val get_stack : Proof.proof -> stack_info list -val get_top_stack : pftreestate -> 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 000000000..dce989bbc --- /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/tactics/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 9c58f06ee..cd695f239 100644 --- a/tactics/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -14,7 +14,6 @@ open Evd open Refiner open Proof_type -open Proof_trees open Tacmach open Tacinterp open Decl_expr @@ -35,7 +34,7 @@ open Goptions (* Strictness option *) -let get_its_info gls = get_info gls.it +let get_its_info gls = get_info gls.sigma gls.it let get_strictness,set_strictness = let strictness = ref false in @@ -51,18 +50,20 @@ let _ = 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 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 = tcl_change_info_gen (Some (pm_in info)) gls +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 None 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 @@ -77,7 +78,7 @@ let is_good_inductive env ind = 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 + if not (Proof.is_done pts) then match get_stack pts with Per (_,_,_,_)::_ -> error "You are inside a proof per cases/induction.\n\ @@ -112,32 +113,23 @@ let assert_postpone 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 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" + tcl_change_info info gls let go_to_proof_mode () = - Pfedit.mutate - (fun pts -> nth_unproven 1 (solve_pftreestate start_proof_tac pts)) + 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}, - function - [] -> - {open_subgoals=0; - goal=sig_it gls; - ref=Some (Daimon,[])} - | _ -> anomaly "Daimon: Wrong number of subtrees") + {it=[];sigma=sig_sig gls} let daimon _ pftree = set_daimon_flag (); @@ -145,7 +137,8 @@ let daimon _ pftree = open_subgoals=0; ref=Some (Daimon,[])} -let daimon_subtree = map_pftreestate (fun _ -> frontier_mapi daimon ) +let daimon_subtree = + fun _ -> Util.anomaly "Todo: Decl_proof_instr.daimon_subtree" (* marking closed blocks *) @@ -159,32 +152,17 @@ 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 pts = + Proof.unfocus proof_focus pts let goto_current_focus_or_top pts = - try - up_until_matching_rule is_focussing_command pts - with Not_found -> top_of_tree pts + try goto_current_focus pts + with Util.UserError _ -> () (* return *) @@ -194,22 +172,21 @@ let close_tactic_mode 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 + goto_current_focus pts2 -let return_from_tactic_mode () = Pfedit.mutate close_tactic_mode +let return_from_tactic_mode () = + Util.anomaly "Todo: Decl_proof_instr.return_from_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 + if Proof.no_focused_goal pts then + goto_current_focus pts else - get_stack pts in - match bt,stack with + let stack =get_stack pts in + match bt,stack with B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] -> - daimon_subtree (goto_current_focus pts) + (goto_current_focus pts) | _, Claim::_ -> error "\"end claim\" expected." | _, Focus_claim::_ -> @@ -223,23 +200,24 @@ let close_block bt pts = | 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) + Proof.is_done 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) + goto_current_focus (pts) | _ -> error "Not inside a proof per cases or induction." else match get_stack pts with - Per (et,_,_,_) :: _ -> pts + Per (et,_,_,_) :: _ -> () | Suppose_case :: Per (et,_,_,_) :: _ -> - goto_current_focus (mark_as_done (daimon_subtree pts)) + goto_current_focus ((pts)) | _ -> error "Not inside a proof per cases or induction." (* Proof instructions *) @@ -252,7 +230,7 @@ let filter_hyps f gls = tclIDTAC else tclTRY (clear [id]) in - tclMAP filter_aux (Environ.named_context_of_val gls.it.evar_hyps) gls + tclMAP filter_aux (pf_hyps gls) gls let local_hyp_prefix = id_of_string "___" @@ -1446,59 +1424,59 @@ let rec preprocess pts instr = | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Pper _ | Prew _ -> check_not_per pts; - true,pts + true | Pescape -> check_not_per pts; - true,pts + true | Pcase _ | Psuppose _ | Pend (B_elim _) -> - true,close_previous_case pts + close_previous_case pts ; + true | Pend bt -> - false,close_block bt pts + 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 (_,_) -> pts + | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Prew (_,_) -> () | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ - | Pescape -> nth_unproven 1 pts + | Pescape -> Proof.focus proof_cond 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 + 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 (mark_as_done pts) + 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 (mark_as_done pts) + goto_current_focus_or_top (pts) let do_instr raw_instr pts = - let has_tactic,pts1 = preprocess pts raw_instr.instr in - let pts2 = + let has_tactic = preprocess pts raw_instr.instr in + begin if has_tactic then - let gl = nth_goal_of_pftreestate 1 pts1 in + 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 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 + Pfedit.by (tclTHEN (eval_instr instr) clean_tmp) + else () end; + postprocess pts raw_instr.instr let proof_instr raw_instr = - Pfedit.mutate (do_instr raw_instr) + let p = Proof_global.give_me_the_proof () in + do_instr raw_instr p (* diff --git a/tactics/decl_proof_instr.mli b/plugins/decl_mode/decl_proof_instr.mli index 1cfcfedf1..0b22b7ac5 100644 --- a/tactics/decl_proof_instr.mli +++ b/plugins/decl_mode/decl_proof_instr.mli @@ -21,20 +21,16 @@ val register_automation_tac: tactic -> unit val automation_tac : tactic -val daimon_subtree: pftreestate -> pftreestate +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 -> pftreestate -> pftreestate +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 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 -> @@ -74,7 +70,7 @@ val register_dep_subcase : val thesis_for : Term.constr -> Term.constr -> Decl_mode.per_info -> Environ.env -> Term.constr -val close_previous_case : pftreestate -> pftreestate +val close_previous_case : Proof.proof -> unit val pop_stacks : (Names.identifier * diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 new file mode 100644 index 000000000..cdfc57b37 --- /dev/null +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -0,0 +1,407 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "parsing/grammar.cma" i*) +(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*) + +(* $Id$ *) + +(* arnaud: veiller à l'aspect tutorial des commentaires *) + +open Pp + +open Decl_expr +open Names +open Term +open Genarg +open Pcoq + +open Pcoq.Constr +open Pcoq.Tactic +open Pcoq.Vernac_ + +let pr_goal gs = + let (g,sigma) = Goal.V82.nf_evar (Tacmach.project gs) (Evd.sig_it gs) in + let env = Goal.V82.unfiltered_env sigma g in + let preamb,thesis,penv,pc = + (str " *** Declarative Mode ***" ++ fnl ()++fnl ()), + (str "thesis := " ++ fnl ()), + Printer.pr_context_of env, + Printer.pr_ltype_env_at_top env (Goal.V82.concl sigma g) + in + preamb ++ + str" " ++ hv 0 (penv ++ fnl () ++ + str (Printer.emacs_str (String.make 1 (Char.chr 253)) "") ++ + str "============================" ++ fnl () ++ + thesis ++ str " " ++ pc) ++ fnl () + +(* arnaud: rebrancher ça +let pr_open_subgoals () = + let p = Proof_global.give_me_the_proof () in + let { Evd.it = goals ; sigma = sigma } = Proof.V82.subgoals p in + let close_cmd = Decl_mode.get_end_command p in + pr_subgoals close_cmd sigma goals +*) + +let pr_proof_instr instr = + Util.anomaly "Cannot print a proof_instr" + (* arnaud: Il nous faut quelque chose de type extr_genarg_printer si on veut aller + dans cette direction + Ppdecl_proof.pr_proof_instr (Global.env()) instr + *) +let pr_raw_proof_instr instr = + Util.anomaly "Cannot print a raw proof_instr" +let pr_glob_proof_instr instr = + Util.anomaly "Cannot print a non-interpreted proof_instr" + +let interp_proof_instr _ { Evd.it = gl ; sigma = sigma }= + Decl_interp.interp_proof_instr + (Decl_mode.get_info sigma gl) + (sigma) + (Goal.V82.env sigma gl) + +let vernac_decl_proof () = + let pf = Proof_global.give_me_the_proof () in + if Proof.is_done pf then + Util.error "Nothing left to prove here." + else + begin + Decl_proof_instr.go_to_proof_mode () ; + Proof_global.set_proof_mode "Declarative" ; + Vernacentries.print_subgoals () + end + +(* spiwack: some bureaucracy is not performed here *) +let vernac_return () = + Decl_proof_instr.return_from_tactic_mode () ; + Proof_global.set_proof_mode "Declarative" ; + Vernacentries.print_subgoals () + +let vernac_proof_instr instr = + Decl_proof_instr.proof_instr instr; + Vernacentries.print_subgoals () + +(* We create a new parser entry [proof_mode]. The Declarative proof mode + will replace the normal parser entry for tactics with this one. *) +let proof_mode = Gram.Entry.create "vernac:proof_command" +(* Auxiliary grammar entry. *) +let proof_instr = Gram.Entry.create "proofmode:instr" + +(* Before we can write an new toplevel command (see below) + which takes a [proof_instr] as argument, we need to declare + how to parse it, print it, globalise it and interprete it. + Normally we could do that easily through ARGUMENT EXTEND, + but as the parsing is fairly complicated we will do it manually to + indirect through the [proof_instr] grammar entry. *) +(* spiwack: proposal: doing that directly from argextend.ml4, maybe ? *) + +(* [Genarg.create_arg] creates a new embedding into Genarg. *) +let (wit_proof_instr,globwit_proof_instr,rawwit_proof_instr) = + Genarg.create_arg "proof_instr" +let _ = Tacinterp.add_interp_genarg "proof_instr" + begin + begin fun e x -> (* 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/parsing/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml index 40c712cdf..40c712cdf 100644 --- a/parsing/ppdecl_proof.ml +++ b/plugins/decl_mode/ppdecl_proof.ml diff --git a/parsing/ppdecl_proof.mli b/plugins/decl_mode/ppdecl_proof.mli index fd6fb6637..fd6fb6637 100644 --- a/parsing/ppdecl_proof.mli +++ b/plugins/decl_mode/ppdecl_proof.mli diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 8a0f02d27..7f4acb856 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 e2cad9449..bef89909d 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 0f048f59a..ff7089613 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 6f6607fcc..c48dff0c6 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 8c22265d6..28de815ca 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 1eae09718..8dc660b42 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 7ca8020dc..c0237ecf7 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 520627115..26b3f9084 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 2e4d07d63..ce65a45ec 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 1e3765da6..fdf3a9bd9 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 23cb07050..06313e8fe 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 490ae89db..d6dece458 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 f1bdd6409..bfa2d4741 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 0eba0f633..e649ad97b 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 1424618f0..181d0fa72 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 9419ba597..d20f9f9b6 100644 --- a/plugins/xml/dumptree.ml4 +++ b/plugins/xml/dumptree.ml4 @@ -56,13 +56,11 @@ let pr_rule_xml pr = function hov 2 (str "<cmpdrule>" ++ 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 "</cmpdrule>" | Daimon -> str "<daimon/>" | Decl_proof _ -> str "<proof/>" -(* | Change_evars -> str "<chgevars/>"*) ;; 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 "<goal>" ++ fnl () ++ str "<concl type=\"" ++ - xmlstream (pr_ltype_env_at_top env g.evar_concl) ++ + xmlstream (pr_ltype_env_at_top env (Goal.V82.concl sigma g)) ++ str "\"/>" ++ (pr_context_xml env)) ++ fnl () ++ str "</goal>") @@ -129,23 +127,9 @@ let pr_goal_xml g = fnl () ++ str "</goal>") ;; -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 "<tree>" ++ fnl () ++ (pr_goal_xml {pf.goal with evar_hyps=hyps'})) ++ fnl () ++ str "</tree>" - | Some(r,spfl) -> - hov 2 (str "<tree>" ++ 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 "</tree>" -;; - 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 1beabf26c..c7b8b556e 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 3f1e0a630..dcfa99792 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 b3b2e2654..8a095bb24 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/evarutil.ml b/pretyping/evarutil.ml index 24850b4ba..6d37cf80f 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 205ca8bd6..39f8dd05a 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 a9b42f052..5b4a3f214 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 b82e6d998..f895ead42 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 cea33c1e9..6aa00c5f2 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 4ec5cf1f1..88d4a4d6b 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 997b28c10..e53be5c0b 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/pretyping/clenv.ml b/proofs/clenv.ml index 7cbaf124a..35db5e6ed 100644 --- a/pretyping/clenv.ml +++ b/proofs/clenv.ml @@ -31,10 +31,10 @@ open Coercion.Default (* Abbreviations *) -let pf_env gls = Global.env_of_context gls.it.evar_hyps -let pf_hyps gls = named_context_of_val gls.it.evar_hyps +let pf_env = Refiner.pf_env +let pf_hyps = Refiner.pf_hyps let pf_type_of gls c = Typing.type_of (pf_env gls) gls.sigma c -let pf_concl gl = gl.it.evar_concl +let pf_concl = Tacmach.pf_concl (******************************************************************) (* Clausal environments *) @@ -142,7 +142,7 @@ let mk_clenv_from_env environ sigma n (c,cty) = 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) + mk_clenv_from_env (pf_env gls) gls.sigma n (c, cty) let mk_clenv_from gls = mk_clenv_from_n gls None @@ -250,12 +250,13 @@ 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) (pf_concl gl) + 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) (pf_concl gl) clenv + (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, @@ -304,9 +305,18 @@ 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 = evars_reset_evd gls.sigma clenv.evd; - env = Global.env_of_context gls.it.evar_hyps } + evd = evd ; + env = Goal.V82.env evd (sig_it gls) } (* [clenv_fchain mv clenv clenv'] * diff --git a/pretyping/clenv.mli b/proofs/clenv.mli index 4f7ac4092..2533fc537 100644 --- a/pretyping/clenv.mli +++ b/proofs/clenv.mli @@ -50,16 +50,16 @@ 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 : Goal.goal 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 + 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 : evar_info sigma -> clausenv -> clausenv +val connect_clenv : Goal.goal sigma -> clausenv -> clausenv val clenv_fchain : ?allow_K:bool -> ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv @@ -72,12 +72,12 @@ val clenv_unify : (* 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 + 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 -> evar_info sigma -> clausenv + bool -> ?flags:unify_flags -> clausenv -> Goal.goal sigma -> clausenv val clenv_dependent : bool -> clausenv -> metavariable list @@ -107,10 +107,10 @@ val clenv_unify_meta_types : ?flags:unify_flags -> clausenv -> clausenv (* 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 -> + Goal.goal sigma -> int option -> constr * constr -> constr bindings -> clausenv val make_clenv_binding : - evar_info sigma -> constr * constr -> constr bindings -> clausenv + 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 diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 9bc818e86..f977768bd 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/evar_refiner.ml b/proofs/evar_refiner.ml index e4fab3f2f..6dfbbdc12 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 0bd616809..28c79d11e 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 000000000..a9202318d --- /dev/null +++ b/proofs/goal.ml @@ -0,0 +1,572 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesscer General Public License Version 2.1 *) +(************************************************************************) + +(* $Id$ *) + +open Term + +(* This module implements the abstract interface to goals *) +(* A general invariant of the module, is that a goal whose associated + evar is defined in the current evar_map, should not be accessed. *) + +(* type of the goals *) +type goal = { + content : Evd.evar; (* Corresponding evar. Allows to retrieve + logical information once put together + with an evar_map. *) + tags : string list (* Heriditary? tags to be displayed *) +} +(* spiwack: I don't deal with the tags, yet. It is a worthy discussion + whether we do want some tags displayed besides the goal or not. *) + +(* access primitive *) +(* invariant : [e] must exist in [em] *) +let content evars { content = e } = Evd.find evars e + + +(* Builds a new (empty) goal with evar [e] *) +let build e = + { content = e ; + tags = [] + } + +(* Builds a new goal with content evar [e] and + inheriting from goal [gl]*) +let descendent gl e = + { gl with content = e} + +(* [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 +let rec advance sigma g = + let evi = Evd.find sigma g.content in + if Option.default false (Evarutil.cleared.get evi.Evd.evar_extra) then + let v = + match evi.Evd.evar_body with + | Evd.Evar_defined c -> 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 000000000..49e3c9b1a --- /dev/null +++ b/proofs/goal.mli @@ -0,0 +1,228 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: goal.mli aspiwack $ *) + +(* This module implements the abstract interface to goals *) + +type goal + +(* spiwack: this primitive is not extremely brilliant. It may be a good + idea to define goals and proof views in the same file to avoid this + sort of communication pipes. But I find it heavy. *) +val build : Evd.evar -> 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 11155d369..7c092bb66 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 0d56da382..560e57736 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 f3658ad4b..6da73c2f6 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 acb852471..9e24061d3 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 000000000..0c298cc63 --- /dev/null +++ b/proofs/proof.ml @@ -0,0 +1,294 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id$ *) + +(* Module defining the last essential tiles of interactive proofs. + The features of the Proof module are undoing and focusing. + A proof is a mutable object, it contains a proofview, and some information + to be able to undo actions, and to unfocus the current view. All three + of these being meant to evolve. + - Proofview: a proof is primarily the data of the current view. + That which is shown to the user (as a remainder, a proofview + is mainly the logical state of the proof, together with the + currently focused goals). + - Focus: a proof has a focus stack: the top of the stack contains + the context in which to unfocus the current view to a view focused + with the rest of the stack. + In addition, this contains, for each of the focus context, a + "focus kind" and a "focus condition" (in practice, and for modularity, + the focus kind is actually stored inside the condition). To unfocus, one + needs to know the focus kind, and the condition (for instance "no condition" or + the proof under focused must be complete) must be met. + - Undo: since proofviews and focus stacks are immutable objects, + it could suffice to hold the previous states, to allow to return to the past. + However, we also allow other modules to do actions that can be undone. + Therefore the undo stack stores action to be ran to undo. +*) + +open Term + +type focus_kind = int +type focus_condition = focus_kind -> 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 000000000..2b1c3f5c2 --- /dev/null +++ b/proofs/proof.mli @@ -0,0 +1,133 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: proof.mli aspiwack $ *) + +(* Module defining the last essential tiles of interactive proofs. + The features of the Proof module are undoing and focusing. + A proof is a mutable object, it contains a proofview, and some information + to be able to undo actions, and to unfocus the current view. All three + of these being meant to evolve. + - Proofview: a proof is primarily the data of the current view. + That which is shown to the user (as a remainder, a proofview + is mainly the logical state of the proof, together with the + currently focused goals). + - Focus: a proof has a focus stack: the top of the stack contains + the context in which to unfocus the current view to a view focused + with the rest of the stack. + In addition, this contains, for each of the focus context, a + "focus kind" and a "focus condition" (in practice, and for modularity, + the focus kind is actually stored inside the condition). To unfocus, one + needs to know the focus kind, and the condition (for instance "no condition" or + the proof under focused must be complete) must be met. + - Undo: since proofviews and focus stacks are immutable objects, + it could suffice to hold the previous states, to allow to return to the past. + However, we also allow other modules to do actions that can be undone. + Therefore the undo stack stores action to be ran to undo. +*) + +open Term + +(* Type of a proof. *) +type proof + + +(*** General proof functions ***) + +val start : (Environ.env * Term.types) list -> 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 000000000..420ff8432 --- /dev/null +++ b/proofs/proof_global.ml @@ -0,0 +1,295 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id$ *) + +(***********************************************************************) +(* *) +(* This module defines the global proof environment *) +(* In particular it keeps tracks of whether or not there is *) +(* a proof which is currently being edited. *) +(* *) +(***********************************************************************) + +open Pp +open Names + +(*** Proof Modes ***) + +(* Type of proof modes : + - A function [set] to set it *from standard mode* + - A function [reset] to reset the *standard mode* from it *) +type proof_mode = { + name : string ; + set : unit -> 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 000000000..84a61c755 --- /dev/null +++ b/proofs/proof_global.mli @@ -0,0 +1,89 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id$ *) + +(***********************************************************************) +(* *) +(* This module defines the global proof environment *) +(* Especially it keeps tracks of whether or not there is *) +(* a proof which is currently being edited. *) +(* *) +(***********************************************************************) + +(* Type of proof modes : + - A name + - A function [set] to set it *from standard mode* + - A function [reset] to reset the *standard mode* from it *) +type proof_mode = { + name : string ; + set : unit -> 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 a5bd073a3..000000000 --- a/proofs/proof_trees.ml +++ /dev/null @@ -1,107 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id$ *) - -open Closure -open Util -open Names -open Nameops -open Term -open Termops -open Sign -open Evd -open Environ -open Evarutil -open Decl_expr -open Proof_type -open Tacred -open Typing -open Libnames -open Nametab - -(* -let is_bind = function - | Tacexpr.Cbindings _ -> 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 6d1fc143d..000000000 --- a/proofs/proof_trees.mli +++ /dev/null @@ -1,48 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id$ i*) - -(*i*) -open Util -open Names -open Term -open Sign -open Evd -open Environ -open Proof_type -(*i*) - -(* This module declares readable constraints, and a few utilities on - constraints and proof trees *) - -val mk_goal : named_context_val -> 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 bc2953408..2fffa3952 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 b5c4a234d..9692f19bc 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 05b86b1a0..66001e77a 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 000000000..a08941df0 --- /dev/null +++ b/proofs/proofview.ml @@ -0,0 +1,491 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id$ *) + +(* The proofview datastructure is a pure datastructure underlying the notion + of proof (namely, a proof is a proofview which can evolve and has safety + mechanisms attached). + The general idea of the structure is that it is composed of a chemical + solution: an unstructured bag of stuff which has some relations with + one another, which represents the various subnodes of the proof, together + with a comb: a datastructure that gives order to some of these nodes, + namely the open goals. + The natural candidate for the solution is an {!Evd.evar_map}, that is + a calculus of evars. The comb is then a list of goals (evars wrapped + with some extra information, like possible name anotations). + There is also need of a list of the evars which initialised the proofview + to be able to return information about the proofview. *) + +(* Type of proofviews. *) +type proofview = { + initial : (Term.constr * Term.types) list; + solution : Evd.evar_map; + comb : Goal.goal list + } + +(* Initialises a proofview, the argument is a list of environement, + conclusion types, and optional names, creating that many initial goals. *) +let init = + let rec aux = function + | [] -> { 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 000000000..cd5520d4e --- /dev/null +++ b/proofs/proofview.mli @@ -0,0 +1,203 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: proofview.mli aspiwack $ *) + +(* The proofview datastructure is a pure datastructure underlying the notion + of proof (namely, a proof is a proofview which can evolve and has safety + mechanisms attached). + The general idea of the structure is that it is composed of a chemical + solution: an unstructured bag of stuff which has some relations with + one another, which represents the various subnodes of the proof, together + with a comb: a datastructure that gives order to some of these nodes, + namely the open goals. + The natural candidate for the solution is an {!Evd.evar_map}, that is + a calculus of evars. The comb is then a list of goals (evars wrapped + with some extra information, like possible name anotations). + There is also need of a list of the evars which initialised the proofview + to be able to return information about the proofview. *) + +open Term + +type proofview + +(* Initialises a proofview, the argument is a list of environement, + conclusion types, creating that many initial goals. *) +val init : (Environ.env * Term.types) list -> 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 a320b67cd..ffb18f265 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<nf+nl then errorlabstrm "Refiner.thensn_tac" (str "Not enough subgoals."); - let gll,pl = - List.split + let gll = (list_map_i (fun i -> apply_sig_tac sigr (if i<nf then tacfi.(i) else 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 e853c12b7..77f2e48a7 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 9e35abfc8..6dbdf17cb 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 a808ca419..f4bb1d922 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 ea8ab5b62..f6b2ce452 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 06c4fab6e..d2bb1a06f 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 b0645744b..a0dea0292 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 4c58edf59..e0e7aae2f 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/eauto.ml4 b/tactics/eauto.ml4 index b0fef2b71..49af8b40e 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 0d1699b1c..d5e4ca17d 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 ad392c7d8..906c32c57 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 9aec0e091..b6112c34f 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 d98d2a2b3..9b04a2cd2 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 d0f6e8226..395a7c206 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 67a73b9be..cb6cb961f 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 e08e5e9ed..1af2d3398 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 0e352110a..6e3957ac0 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 fe4e9f6aa..71ee29f8c 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 332855052..045f70c61 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 b9c8ab928..3dd73c92c 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 41fab4e71..e6201aad9 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 b885b1524..333d6a3a2 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 0d9c9ae9d..a8193ef3c 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 685c72470..45b949716 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 ee12c6a8d..e2c623201 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 4fd2a8f0a..e2e5b563f 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 6f7645841..d187941d2 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 ae2c3d77f..9fd6e0088 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 0e66c43c3..d8c7326a9 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 01e83b1ad..0fb9a33b2 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 5d4f014a3..f4e9f6f58 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 886f4033d..36f1e96e9 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 <rule>") - | 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 44e8b7ab4..58df8a906 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 0db000a48..e216f2520 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 98a79a9ce..9d4b5ec0c 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 = |