From 2bc88f9a536c3db3c2d4a38a8a0da0500b895c7b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 14 Sep 2015 18:35:48 +0200 Subject: Univs: Add universe binding lists to definitions ... lemmas and inductives to control which universes are bound and where in universe polymorphic definitions. Names stay outside the kernel. --- proofs/pfedit.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'proofs') diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index d024c01ba5..c77ab06b94 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -133,7 +133,7 @@ open Decl_kinds let next = let n = ref 0 in fun () -> incr n; !n let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theorem) typ tac = - let evd = Evd.from_env ~ctx Environ.empty_env in + let evd = Evd.from_ctx ctx in start_proof id goal_kind evd sign typ (fun _ -> ()); try let status = by tac in -- cgit v1.2.3 From 48c78b719392276b2e87be5ea368c71c01f14c85 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 17 Sep 2015 10:21:41 +0200 Subject: Fix previous merge. --- proofs/pfedit.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'proofs') diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 3363d0300d..5e8221b811 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -133,7 +133,7 @@ open Decl_kinds let next = let n = ref 0 in fun () -> incr n; !n let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theorem) typ tac = - let evd = Evd.from_env ~ctx in + let evd = Evd.from_ctx ctx in let terminator = Proof_global.make_terminator (fun _ -> ()) in start_proof id goal_kind evd sign typ terminator; try -- cgit v1.2.3 From b3bd2696c31ad2cb544f3436ddb5a237fe7fa6fe Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 20 Sep 2015 15:34:19 +0200 Subject: Proof: suggest Admitted->Qed only if the proof is really complete (#4349) --- proofs/proof.ml | 10 ++++++++-- proofs/proof.mli | 3 +++ proofs/proof_global.ml | 2 +- 3 files changed, 12 insertions(+), 3 deletions(-) (limited to 'proofs') diff --git a/proofs/proof.ml b/proofs/proof.ml index a7077d9110..c7aa5bad97 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -173,6 +173,12 @@ let is_done p = (* spiwack: for compatibility with <= 8.2 proof engine *) let has_unresolved_evar p = Proofview.V82.has_unresolved_evar p.proofview +let has_shelved_goals p = not (CList.is_empty (p.shelf)) +let has_given_up_goals p = not (CList.is_empty (p.given_up)) + +let is_complete p = + is_done p && not (has_unresolved_evar p) && + not (has_shelved_goals p) && not (has_given_up_goals p) (* Returns the list of partial proofs to initial goals *) let partial_proof p = Proofview.partial_proof p.entry p.proofview @@ -305,9 +311,9 @@ end let return p = if not (is_done p) then raise UnfinishedProof - else if not (CList.is_empty (p.shelf)) then + else if has_shelved_goals p then raise HasShelvedGoals - else if not (CList.is_empty (p.given_up)) then + else if has_given_up_goals p then raise HasGivenUpGoals else if has_unresolved_evar p then (* spiwack: for compatibility with <= 8.3 proof engine *) diff --git a/proofs/proof.mli b/proofs/proof.mli index a2e10d8133..a0ed0654db 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -75,6 +75,9 @@ val initial_euctx : proof -> Evd.evar_universe_context to be considered (this does not require that all evars have been solved). *) val is_done : proof -> bool +(* Like is_done, but this time it really means done (i.e. nothing left to do) *) +val is_complete : proof -> bool + (* Returns the list of partial proofs to initial goals. *) val partial_proof : proof -> Term.constr list diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index c02b909164..6c963bf705 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -341,7 +341,7 @@ type closed_proof_output = (Term.constr * Declareops.side_effects) list * Evd.ev let return_proof ?(allow_partial=false) () = let { pid; proof; strength = (_,poly,_) } = cur_pstate () in if allow_partial then begin - if Proof.is_done proof then begin + if Proof.is_complete proof then begin msg_warning (str"The proof of " ++ str (Names.Id.to_string pid) ++ str" is complete, no need to end it with Admitted"); end; -- cgit v1.2.3 From 6459c0e8c240f0997873c50d4ec749effaba2f44 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 31 Jul 2015 18:33:06 +0200 Subject: Removing the generalization of the body of inductive schemes from Auto_ind_decl over the internal lemmas. The schemes are built in the main process and the internal lemmas are actually already also in the environment. --- proofs/pfedit.ml | 4 ++-- proofs/pfedit.mli | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'proofs') diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index c77ab06b94..ceb4facc1e 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -145,12 +145,12 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo delete_current_proof (); iraise reraise -let build_by_tactic env ctx ?(poly=false) typ tac = +let build_by_tactic ?(side_eff=true) env ctx ?(poly=false) typ tac = let id = Id.of_string ("temporary_proof"^string_of_int (next())) in let sign = val_of_named_context (named_context env) in let gk = Global, poly, Proof Theorem in let ce, status, univs = build_constant_by_tactic id ctx sign ~goal_kind:gk typ tac in - let ce = Term_typing.handle_entry_side_effects env ce in + let ce = if side_eff then Term_typing.handle_entry_side_effects env ce else { ce with const_entry_body = Future.chain ~pure:true ce.const_entry_body (fun (pt, _) -> pt, Declareops.no_seff) } in let (cb, ctx), se = Future.force ce.const_entry_body in assert(Declareops.side_effects_is_empty se); assert(Univ.ContextSet.is_empty ctx); diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 5e0fb4dd36..4aa3c3bfd2 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -153,7 +153,7 @@ val build_constant_by_tactic : types -> unit Proofview.tactic -> Entries.definition_entry * bool * Evd.evar_universe_context -val build_by_tactic : env -> Evd.evar_universe_context -> ?poly:polymorphic -> +val build_by_tactic : ?side_eff:bool -> env -> Evd.evar_universe_context -> ?poly:polymorphic -> types -> unit Proofview.tactic -> constr * bool * Evd.evar_universe_context -- cgit v1.2.3 From ca14b0bb67c9db000736333a056fc147c6f5199c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 27 Sep 2015 14:16:54 +0200 Subject: Removing uselessly duplicated function in Evd. --- proofs/clenv.ml | 2 +- proofs/clenvtac.ml | 2 +- proofs/logic.ml | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) (limited to 'proofs') diff --git a/proofs/clenv.ml b/proofs/clenv.ml index a2cccc0e0b..16146f4846 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -119,7 +119,7 @@ let clenv_environments evd bound t = clrec (evd,[]) bound t let mk_clenv_from_env env sigma n (c,cty) = - let evd = create_goal_evar_defs sigma in + let evd = clear_metas sigma in let (evd,args,concl) = clenv_environments evd n cty in { templval = mk_freelisted (applist (c,args)); templtyp = mk_freelisted concl; diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index aaa49f1169..f54d4c4470 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -121,7 +121,7 @@ let unify ?(flags=fail_quick_unif_flags) m = Proofview.Goal.enter begin fun gl -> let env = Tacmach.New.pf_env gl in let n = Tacmach.New.pf_nf_concl gl in - let evd = create_goal_evar_defs (Proofview.Goal.sigma gl) in + let evd = clear_metas (Proofview.Goal.sigma gl) in try let evd' = w_unify env evd CONV ~flags m n in Proofview.Unsafe.tclEVARSADVANCE evd' diff --git a/proofs/logic.ml b/proofs/logic.ml index 5c48995fc7..7d101b4c72 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -95,12 +95,12 @@ let check_typability env sigma c = forces the user to give them in order). *) let clear_hyps env sigma ids sign cl = - let evdref = ref (Evd.create_goal_evar_defs sigma) in + let evdref = ref (Evd.clear_metas sigma) in let (hyps,cl) = Evarutil.clear_hyps_in_evi env evdref sign cl ids in (hyps, cl, !evdref) let clear_hyps2 env sigma ids sign t cl = - let evdref = ref (Evd.create_goal_evar_defs sigma) in + let evdref = ref (Evd.clear_metas sigma) in let (hyps,t,cl) = Evarutil.clear_hyps2_in_evi env evdref sign t cl ids in (hyps, t, cl, !evdref) -- cgit v1.2.3 From a3d7630d74b720b771e880dcf0fcad05de553a6e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 27 Sep 2015 16:39:36 +0200 Subject: Removing meta_with_name from Evd. --- proofs/clenv.ml | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) (limited to 'proofs') diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 16146f4846..0697c94d74 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -432,6 +432,44 @@ let check_bindings bl = str " occurs more than once in binding list.") | [] -> () +let explain_no_such_bound_variable evd id = + let fold l (n, clb) = + let na = match clb with + | Cltyp (na, _) -> na + | Clval (na, _, _) -> na + in + if na != Anonymous then out_name na :: l else l + in + let mvl = List.fold_left fold [] (Evd.meta_list evd) in + errorlabstrm "Evd.meta_with_name" + (str"No such bound variable " ++ pr_id id ++ + (if mvl == [] then str " (no bound variables at all in the expression)." + else + (str" (possible name" ++ + str (if List.length mvl == 1 then " is: " else "s are: ") ++ + pr_enum pr_id mvl ++ str")."))) + +let meta_with_name evd id = + let na = Name id in + let fold (l1, l2 as l) (n, clb) = + let (na',def) = match clb with + | Cltyp (na, _) -> (na, false) + | Clval (na, _, _) -> (na, true) + in + if Name.equal na na' then if def then (n::l1,l2) else (n::l1,n::l2) + else l + in + let (mvl, mvnodef) = List.fold_left fold ([], []) (Evd.meta_list evd) in + match mvnodef, mvl with + | _,[] -> + explain_no_such_bound_variable evd id + | ([n],_|_,[n]) -> + n + | _ -> + errorlabstrm "Evd.meta_with_name" + (str "Binder name \"" ++ pr_id id ++ + strbrk "\" occurs more than once in clause.") + let meta_of_binder clause loc mvs = function | NamedHyp s -> meta_with_name clause.evd s | AnonHyp n -> -- cgit v1.2.3 From 88abc50ece70405d71777d5350ca2fa70c1ff437 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Fri, 2 Oct 2015 14:41:57 +0200 Subject: Changed status of Info messages from notice to info. This fixes a bug in proofgeneral. PG will now diplay this message eagerly. Otherwise since they appear before the goal, they are considered outdated and not displayed. --- proofs/pfedit.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'proofs') diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index ceb4facc1e..05a2975458 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -108,7 +108,7 @@ let solve ?with_end_tac gi info_lvl tac pr = let () = match info_lvl with | None -> () - | Some i -> Pp.msg_notice (hov 0 (Proofview.Trace.pr_info ~lvl:i info)) + | Some i -> Pp.msg_info (hov 0 (Proofview.Trace.pr_info ~lvl:i info)) in (p,status) with -- cgit v1.2.3 From 11cdf7c2ca0017f6bae906f9c9d9eef41972affe Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Sep 2015 15:16:06 +0200 Subject: Univs: fix handling of side effects/delayed proofs - When there are side effects which might enrich the initial universes of a proof, keep the initial and refined universe contexts apart like for delayed proofs, ensuring universes are declared before they are used in the right order. - Fix undefined levels in proof statements so that they can't be lowered to Set by a subsequent, delayed proof. --- proofs/proof_global.ml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) (limited to 'proofs') diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 6c963bf705..254aa8f783 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -290,16 +290,14 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = let body = c and typ = nf t in let used_univs_body = Universes.universes_of_constr body in let used_univs_typ = Universes.universes_of_constr typ in - if keep_body_ucst_separate then + if keep_body_ucst_separate || not (Declareops.side_effects_is_empty eff) then let initunivs = Evd.evar_context_universe_context initial_euctx in let ctx = Evd.evar_universe_context_set initunivs universes in (* For vi2vo compilation proofs are computed now but we need to * complement the univ constraints of the typ with the ones of * the body. So we keep the two sets distinct. *) let ctx_body = restrict_universe_context ctx used_univs_body in - let ctx_typ = restrict_universe_context ctx used_univs_typ in - let univs_typ = Univ.ContextSet.to_context ctx_typ in - (univs_typ, typ), ((body, ctx_body), eff) + (initunivs, typ), ((body, ctx_body), eff) else let initunivs = Univ.UContext.empty in let ctx = Evd.evar_universe_context_set initunivs universes in -- cgit v1.2.3 From 13337793ea7f709eaa50965797e4f79a3aa51a2b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 18:35:44 +0200 Subject: Univs: fix handling of evd's universes and side effects in build_by_tactic --- proofs/pfedit.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'proofs') diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 05a2975458..00ef8ecafd 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -152,9 +152,9 @@ let build_by_tactic ?(side_eff=true) env ctx ?(poly=false) typ tac = let ce, status, univs = build_constant_by_tactic id ctx sign ~goal_kind:gk typ tac in let ce = if side_eff then Term_typing.handle_entry_side_effects env ce else { ce with const_entry_body = Future.chain ~pure:true ce.const_entry_body (fun (pt, _) -> pt, Declareops.no_seff) } in let (cb, ctx), se = Future.force ce.const_entry_body in + let univs' = Evd.merge_context_set Evd.univ_rigid (Evd.from_ctx univs) ctx in assert(Declareops.side_effects_is_empty se); - assert(Univ.ContextSet.is_empty ctx); - cb, status, univs + cb, status, Evd.evar_universe_context univs' let refine_by_tactic env sigma ty tac = (** Save the initial side-effects to restore them afterwards. We set the -- cgit v1.2.3 From 840155eafd9607c7656c80770de1e2819fe56a13 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Tue, 6 Oct 2015 13:38:15 +0200 Subject: Fixing emacs output in debugging mode. Goal displaying during Debugging ltac is a notice message now. Other messages are debug messages. This does not change anything in coqide or coqtop, but allows proofgeneral to dispatch them in the right buffers (pg had to be fixed too). --- proofs/logic_monad.ml | 6 +++++- proofs/logic_monad.mli | 4 ++++ proofs/tactic_debug.ml | 5 +++-- 3 files changed, 12 insertions(+), 3 deletions(-) (limited to 'proofs') diff --git a/proofs/logic_monad.ml b/proofs/logic_monad.ml index cb3e5a1860..81f02b66db 100644 --- a/proofs/logic_monad.ml +++ b/proofs/logic_monad.ml @@ -95,7 +95,11 @@ struct let print_char = fun c -> (); fun () -> print_char c (** {!Pp.pp}. The buffer is also flushed. *) - let print = fun s -> (); fun () -> try Pp.msg_info s; Pp.pp_flush () with e -> + let print_debug = fun s -> (); fun () -> try Pp.msg_info s; Pp.pp_flush () with e -> + let (e, info) = Errors.push e in raise ~info e () + + (** {!Pp.pp}. The buffer is also flushed. *) + let print = fun s -> (); fun () -> try Pp.msg_notice s; Pp.pp_flush () with e -> let (e, info) = Errors.push e in raise ~info e () let timeout = fun n t -> (); fun () -> diff --git a/proofs/logic_monad.mli b/proofs/logic_monad.mli index ab729aff71..511dd7a6ed 100644 --- a/proofs/logic_monad.mli +++ b/proofs/logic_monad.mli @@ -58,6 +58,10 @@ module NonLogical : sig (** {!Pp.pp}. The buffer is also flushed. *) val print : Pp.std_ppcmds -> unit t + (* FIXME: shouldn't we have a logger instead? *) + (** {!Pp.pp}. The buffer is also flushed. *) + val print_debug : Pp.std_ppcmds -> unit t + (** [Pervasives.raise]. Except that exceptions are wrapped with {!Exception}. *) val raise : ?info:Exninfo.info -> exn -> 'a t diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml index d7f4b5ead5..667765dbf2 100644 --- a/proofs/tactic_debug.ml +++ b/proofs/tactic_debug.ml @@ -32,7 +32,8 @@ let explain_logic_error = ref (fun e -> mt()) let explain_logic_error_no_anomaly = ref (fun e -> mt()) -let msg_tac_debug s = Proofview.NonLogical.print (s++fnl()) +let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) +let msg_tac_notice s = Proofview.NonLogical.print (s++fnl()) (* Prints the goal *) @@ -48,7 +49,7 @@ let db_pr_goal gl = let db_pr_goal = Proofview.Goal.nf_enter begin fun gl -> let pg = db_pr_goal gl in - Proofview.tclLIFT (msg_tac_debug (str "Goal:" ++ fnl () ++ pg)) + Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) end -- cgit v1.2.3 From 9ea8867a0fa8f2a52df102732fdc1a931c659826 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 30 Sep 2015 22:12:25 +0200 Subject: Proof using: let-in policy, optional auto-clear, forward closure* - "Proof using p*" means: use p and any section var about p. - Simplify the grammar/parser for proof using . - Section variables with a body (let-in) are pulled in automatically since they are safe to be used (add no extra quantification) - automatic clear of "unused" section variables made optional: Set Proof Using Clear Unused. since clearing section hypotheses does not "always work" (e.g. hint databases are not really cleaned) - term_typing: trigger a "suggest proof using" message also for Let theorems. --- proofs/pfedit.mli | 3 +- proofs/proof_global.ml | 28 +++++++- proofs/proof_global.mli | 6 +- proofs/proof_using.ml | 172 ++++++++++++++++++++++++------------------------ proofs/proof_using.mli | 15 +---- 5 files changed, 121 insertions(+), 103 deletions(-) (limited to 'proofs') diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 4aa3c3bfd2..b1fba132d9 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -117,7 +117,8 @@ val set_end_tac : Tacexpr.raw_tactic_expr -> unit (** {6 ... } *) (** [set_used_variables l] declares that section variables [l] will be used in the proof *) -val set_used_variables : Id.t list -> Context.section_context +val set_used_variables : + Id.t list -> Context.section_context * (Loc.t * Names.Id.t) list val get_used_variables : unit -> Context.section_context option (** {6 ... } *) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 254aa8f783..f777e6ed7a 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -250,17 +250,43 @@ let start_dependent_proof id str goals terminator = let get_used_variables () = (cur_pstate ()).section_vars +let proof_using_auto_clear = ref true +let _ = Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optdepr = false; + Goptions.optname = "Proof using Clear Unused"; + Goptions.optkey = ["Proof";"Using";"Clear";"Unused"]; + Goptions.optread = (fun () -> !proof_using_auto_clear); + Goptions.optwrite = (fun b -> proof_using_auto_clear := b) } + let set_used_variables l = let env = Global.env () in let ids = List.fold_right Id.Set.add l Id.Set.empty in let ctx = Environ.keep_hyps env ids in + let ctx_set = + List.fold_right Id.Set.add (List.map pi1 ctx) Id.Set.empty in + let vars_of = Environ.global_vars_set in + let aux env entry (ctx, all_safe, to_clear as orig) = + match entry with + | (x,None,_) -> + if Id.Set.mem x all_safe then orig + else (ctx, all_safe, (Loc.ghost,x)::to_clear) + | (x,Some bo, ty) as decl -> + if Id.Set.mem x all_safe then orig else + let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in + if Id.Set.subset vars all_safe + then (decl :: ctx, Id.Set.add x all_safe, to_clear) + else (ctx, all_safe, (Loc.ghost,x) :: to_clear) in + let ctx, _, to_clear = + Environ.fold_named_context aux env ~init:(ctx,ctx_set,[]) in + let to_clear = if !proof_using_auto_clear then to_clear else [] in match !pstates with | [] -> raise NoCurrentProof | p :: rest -> if not (Option.is_empty p.section_vars) then Errors.error "Used section variables can be declared only once"; pstates := { p with section_vars = Some ctx} :: rest; - ctx + ctx, to_clear let get_open_goals () = let gl, gll, shelf , _ , _ = Proof.proof (cur_pstate ()).proof in diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index b5dd5ef85f..028116049c 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -129,8 +129,10 @@ val set_interp_tac : -> unit (** Sets the section variables assumed by the proof, returns its closure - * (w.r.t. type dependencies *) -val set_used_variables : Names.Id.t list -> Context.section_context + * (w.r.t. type dependencies and let-ins covered by it) + a list of + * ids to be cleared *) +val set_used_variables : + Names.Id.t list -> Context.section_context * (Loc.t * Names.Id.t) list val get_used_variables : unit -> Context.section_context option (**********************************************************) diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml index f66e965712..7eed1cb317 100644 --- a/proofs/proof_using.ml +++ b/proofs/proof_using.ml @@ -11,20 +11,15 @@ open Environ open Util open Vernacexpr -let to_string = function - | SsAll -> "All" - | SsType -> "Type" - | SsExpr(SsSet l)-> String.concat " " (List.map Id.to_string (List.map snd l)) - | SsExpr e -> - let rec aux = function - | SsSet [] -> "( )" - | SsSet [_,x] -> Id.to_string x - | SsSet l -> - "(" ^ String.concat " " (List.map Id.to_string (List.map snd l)) ^ ")" - | SsCompl e -> "-" ^ aux e^"" - | SsUnion(e1,e2) -> "("^aux e1 ^" + "^ aux e2^")" - | SsSubstr(e1,e2) -> "("^aux e1 ^" - "^ aux e2^")" - in aux e +let to_string e = + let rec aux = function + | SsEmpty -> "()" + | SsSingl (_,id) -> "("^Id.to_string id^")" + | SsCompl e -> "-" ^ aux e^"" + | SsUnion(e1,e2) -> "("^aux e1 ^" + "^ aux e2^")" + | SsSubstr(e1,e2) -> "("^aux e1 ^" - "^ aux e2^")" + | SsFwdClose e -> "("^aux e^")*" + in aux e let known_names = Summary.ref [] ~name:"proofusing-nameset" @@ -36,30 +31,48 @@ let in_nameset = discharge_function = (fun _ -> None) } +let rec close_fwd e s = + let s' = + List.fold_left (fun s (id,b,ty) -> + let vb = Option.(default Id.Set.empty (map (global_vars_set e) b)) in + let vty = global_vars_set e ty in + let vbty = Id.Set.union vb vty in + if Id.Set.exists (fun v -> Id.Set.mem v s) vbty + then Id.Set.add id (Id.Set.union s vbty) else s) + s (named_context e) + in + if Id.Set.equal s s' then s else close_fwd e s' +;; + let rec process_expr env e ty = - match e with - | SsAll -> - List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty - | SsExpr e -> - let rec aux = function - | SsSet l -> set_of_list env (List.map snd l) - | SsUnion(e1,e2) -> Id.Set.union (aux e1) (aux e2) - | SsSubstr(e1,e2) -> Id.Set.diff (aux e1) (aux e2) - | SsCompl e -> Id.Set.diff (full_set env) (aux e) - in - aux e - | SsType -> - List.fold_left (fun acc ty -> + let rec aux = function + | SsEmpty -> Id.Set.empty + | SsSingl (_,id) -> set_of_id env ty id + | SsUnion(e1,e2) -> Id.Set.union (aux e1) (aux e2) + | SsSubstr(e1,e2) -> Id.Set.diff (aux e1) (aux e2) + | SsCompl e -> Id.Set.diff (full_set env) (aux e) + | SsFwdClose e -> close_fwd env (aux e) + in + aux e + +and set_of_id env ty id = + if Id.to_string id = "Type" then + List.fold_left (fun acc ty -> Id.Set.union (global_vars_set env ty) acc) Id.Set.empty ty -and set_of_list env = function - | [x] when CList.mem_assoc_f Id.equal x !known_names -> - process_expr env (CList.assoc_f Id.equal x !known_names) [] - | l -> List.fold_right Id.Set.add l Id.Set.empty -and full_set env = set_of_list env (List.map pi1 (named_context env)) + else if Id.to_string id = "All" then + List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty + else if CList.mem_assoc_f Id.equal id !known_names then + process_expr env (CList.assoc_f Id.equal id !known_names) [] + else Id.Set.singleton id + +and full_set env = + List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty let process_expr env e ty = - let s = Id.Set.union (process_expr env SsType ty) (process_expr env e []) in + let ty_expr = SsSingl(Loc.ghost, Id.of_string "Type") in + let v_ty = process_expr env ty_expr ty in + let s = Id.Set.union v_ty (process_expr env e ty) in Id.Set.elements s let name_set id expr = Lib.add_anonymous_leaf (in_nameset (id,expr)) @@ -77,62 +90,49 @@ let minimize_hyps env ids = in aux ids -let minimize_unused_hyps env ids = - let all_ids = List.map pi1 (named_context env) in - let deps_of = - let cache = - List.map (fun id -> id,really_needed env (Id.Set.singleton id)) all_ids in - fun id -> List.assoc id cache in - let inv_dep_of = - let cache_sum cache id stuff = - try Id.Map.add id (Id.Set.add stuff (Id.Map.find id cache)) cache - with Not_found -> Id.Map.add id (Id.Set.singleton stuff) cache in - let cache = - List.fold_left (fun cache id -> - Id.Set.fold (fun d cache -> cache_sum cache d id) - (Id.Set.remove id (deps_of id)) cache) - Id.Map.empty all_ids in - fun id -> try Id.Map.find id cache with Not_found -> Id.Set.empty in - let rec aux s = - let s' = - Id.Set.fold (fun id s -> - if Id.Set.subset (inv_dep_of id) s then Id.Set.diff s (inv_dep_of id) - else s) - s s in - if Id.Set.equal s s' then s else aux s' in - aux ids - -let suggest_Proof_using kn env vars ids_typ context_ids = +let remove_ids_and_lets env s ids = + let not_ids id = not (Id.Set.mem id ids) in + let no_body id = named_body id env = None in + let deps id = really_needed env (Id.Set.singleton id) in + (Id.Set.filter (fun id -> + not_ids id && + (no_body id || + Id.Set.exists not_ids (Id.Set.filter no_body (deps id)))) s) + +let suggest_Proof_using name env vars ids_typ context_ids = let module S = Id.Set in let open Pp in - let used = S.union vars ids_typ in - let needed = minimize_hyps env used in - let all_needed = really_needed env needed in - let all = List.fold_right S.add context_ids S.empty in - let unneeded = minimize_unused_hyps env (S.diff all needed) in - let pr_set s = + let print x = prerr_endline (string_of_ppcmds x) in + let pr_set parens s = let wrap ppcmds = - if S.cardinal s > 1 || S.equal s (S.singleton (Id.of_string "All")) - then str "(" ++ ppcmds ++ str ")" + if parens && S.cardinal s > 1 then str "(" ++ ppcmds ++ str ")" else ppcmds in wrap (prlist_with_sep (fun _ -> str" ") Id.print (S.elements s)) in + let used = S.union vars ids_typ in + let needed = minimize_hyps env (remove_ids_and_lets env used ids_typ) in + let all_needed = really_needed env needed in + let all = List.fold_right S.add context_ids S.empty in + let fwd_typ = close_fwd env ids_typ in if !Flags.debug then begin - prerr_endline (string_of_ppcmds (str "All " ++ pr_set all)); - prerr_endline (string_of_ppcmds (str "Type" ++ pr_set ids_typ)); - prerr_endline (string_of_ppcmds (str "needed " ++ pr_set needed)); - prerr_endline (string_of_ppcmds (str "unneeded " ++ pr_set unneeded)); + print (str "All " ++ pr_set false all); + print (str "Type " ++ pr_set false ids_typ); + print (str "needed " ++ pr_set false needed); + print (str "all_needed " ++ pr_set false all_needed); + print (str "Type* " ++ pr_set false fwd_typ); end; + let valid_exprs = ref [] in + let valid e = valid_exprs := e :: !valid_exprs in + if S.is_empty needed then valid (str "Type"); + if S.equal all_needed fwd_typ then valid (str "Type*"); + if S.equal all all_needed then valid(str "All"); + valid (pr_set false needed); msg_info ( - str"The proof of "++ - Names.Constant.print kn ++ spc() ++ str "should start with:"++spc()++ - str"Proof using " ++ - if S.is_empty needed then str "." - else if S.subset needed ids_typ then str "Type." - else if S.equal all all_needed then str "All." - else - let s1 = string_of_ppcmds (str "-" ++ pr_set unneeded ++ str".") in - let s2 = string_of_ppcmds (pr_set needed ++ str".") in - if String.length s1 < String.length s2 then str s1 else str s2) + str"The proof of "++ str name ++ spc() ++ + str "should start with one of the following commands:"++spc()++ + v 0 ( + prlist_with_sep cut (fun x->str"Proof using " ++x++ str". ") !valid_exprs)); + string_of_ppcmds (prlist_with_sep (fun _ -> str";") (fun x->x) !valid_exprs) +;; let value = ref false @@ -146,13 +146,13 @@ let _ = Goptions.optwrite = (fun b -> value := b; if b then Term_typing.set_suggest_proof_using suggest_Proof_using - else Term_typing.set_suggest_proof_using (fun _ _ _ _ _ -> ()) + else Term_typing.set_suggest_proof_using (fun _ _ _ _ _ -> "") ) } -let value = ref "_unset_" +let value = ref None let _ = - Goptions.declare_string_option + Goptions.declare_stringopt_option { Goptions.optsync = true; Goptions.optdepr = false; Goptions.optname = "default value for Proof using"; @@ -161,6 +161,4 @@ let _ = Goptions.optwrite = (fun b -> value := b;) } -let get_default_proof_using () = - if !value = "_unset_" then None - else Some !value +let get_default_proof_using () = !value diff --git a/proofs/proof_using.mli b/proofs/proof_using.mli index fb3497f106..dcf8a0fcd2 100644 --- a/proofs/proof_using.mli +++ b/proofs/proof_using.mli @@ -6,21 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - -(* [minimize_hyps e s1] gives [s2] s.t. [Id.Set.subset s2 s1] is [true] - * and [keep_hyps e s1] is equal to [keep_hyps e s2]. Inefficient. *) -val minimize_hyps : Environ.env -> Names.Id.Set.t -> Names.Id.Set.t - -(* [minimize_unused_hyps e s1] gives [s2] s.t. [Id.Set.subset s2 s1] is [true] - * and s.t. calling [clear s1] would do the same as [clear s2]. Inefficient. *) -val minimize_unused_hyps : Environ.env -> Names.Id.Set.t -> Names.Id.Set.t - val process_expr : - Environ.env -> Vernacexpr.section_subset_descr -> Constr.types list -> + Environ.env -> Vernacexpr.section_subset_expr -> Constr.types list -> Names.Id.t list -val name_set : Names.Id.t -> Vernacexpr.section_subset_descr -> unit +val name_set : Names.Id.t -> Vernacexpr.section_subset_expr -> unit -val to_string : Vernacexpr.section_subset_descr -> string +val to_string : Vernacexpr.section_subset_expr -> string val get_default_proof_using : unit -> string option -- cgit v1.2.3 From 73daf37ccc7a44cd29c9b67405111756c75cb26a Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 9 Oct 2015 09:48:48 +0200 Subject: Remove misleading warning (Close #4365) --- proofs/proof_global.ml | 4 ---- 1 file changed, 4 deletions(-) (limited to 'proofs') diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index f777e6ed7a..3e06294e64 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -365,10 +365,6 @@ type closed_proof_output = (Term.constr * Declareops.side_effects) list * Evd.ev let return_proof ?(allow_partial=false) () = let { pid; proof; strength = (_,poly,_) } = cur_pstate () in if allow_partial then begin - if Proof.is_complete proof then begin - msg_warning (str"The proof of " ++ str (Names.Id.to_string pid) ++ - str" is complete, no need to end it with Admitted"); - end; let proofs = Proof.partial_proof proof in let _,_,_,_, evd = Proof.proof proof in let eff = Evd.eval_side_effects evd in -- cgit v1.2.3 From bf0499bc507d5a39c3d5e3bf1f69191339270729 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 14 Oct 2015 18:18:01 +0200 Subject: Fix LemmaOverloading Do not normalize the type of a proof according to the final universes when keep_body_ucst_separate is true, otherwise the type might not be retypable in the initial context... --- proofs/proof_global.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'proofs') diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 3e06294e64..a0ead42ef3 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -313,7 +313,12 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = if poly || now then let make_body t (c, eff) = let open Universes in - let body = c and typ = nf t in + let body = c in + let typ = + if not (keep_body_ucst_separate || not (Declareops.side_effects_is_empty eff)) then + nf t + else t + in let used_univs_body = Universes.universes_of_constr body in let used_univs_typ = Universes.universes_of_constr typ in if keep_body_ucst_separate || not (Declareops.side_effects_is_empty eff) then -- cgit v1.2.3 From 3116aeff0cdc51e6801f3e8ae4a6c0533e1a75ac Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 8 Oct 2015 18:06:55 +0200 Subject: Fix #4346 1/2: native casts were not inferring universe constraints. --- proofs/redexpr.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'proofs') diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index f172bbdd1a..be92f2b04c 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -35,8 +35,7 @@ let cbv_native env sigma c = cbv_vm env sigma c else let ctyp = Retyping.get_type_of env sigma c in - let evars = Nativenorm.evars_of_evar_map sigma in - Nativenorm.native_norm env evars c ctyp + Nativenorm.native_norm env sigma c ctyp let whd_cbn flags env sigma t = let (state,_) = -- cgit v1.2.3 From d558bf5289e87899a850dda410a3a3c4de1ce979 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 17 Oct 2015 18:55:42 +0200 Subject: Clarifying and documenting the UState API. --- proofs/proof_global.ml | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) (limited to 'proofs') diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 5c6ed33961..4af18ab2d5 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -298,6 +298,11 @@ let get_open_goals () = (List.map (fun (l1,l2) -> List.length l1 + List.length l2) gll) + List.length shelf +let constrain_variables init uctx = + let levels = Univ.Instance.levels (Univ.UContext.instance init) in + let cstrs = UState.constrain_variables levels uctx in + Univ.ContextSet.add_constraints cstrs (UState.context_set uctx) + let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = let { pid; section_vars; strength; proof; terminator } = cur_pstate () in let poly = pi2 strength (* Polymorphic *) in @@ -326,7 +331,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = let used_univs_typ = Universes.universes_of_constr typ in if keep_body_ucst_separate || not (Declareops.side_effects_is_empty eff) then let initunivs = Evd.evar_context_universe_context initial_euctx in - let ctx = Evd.evar_universe_context_set initunivs universes in + let ctx = constrain_variables initunivs universes in (* For vi2vo compilation proofs are computed now but we need to * complement the univ constraints of the typ with the ones of * the body. So we keep the two sets distinct. *) @@ -334,7 +339,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = (initunivs, typ), ((body, ctx_body), eff) else let initunivs = Univ.UContext.empty in - let ctx = Evd.evar_universe_context_set initunivs universes in + let ctx = constrain_variables initunivs universes in (* Since the proof is computed now, we can simply have 1 set of * constraints in which we merge the ones for the body and the ones * for the typ *) @@ -349,7 +354,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = let initunivs = Evd.evar_context_universe_context initial_euctx in Future.from_val (initunivs, nf t), Future.chain ~pure:true p (fun (pt,eff) -> - (pt,Evd.evar_universe_context_set initunivs (Future.force univs)),eff) + (pt,constrain_variables initunivs (Future.force univs)),eff) in let entries = Future.map2 (fun p (_, t) -> -- cgit v1.2.3 From c8b57f62f5ad12f8926f57fcdbc5bb2ee3c63eff Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 13 Oct 2015 11:40:22 +0200 Subject: Miscellaneous typos, spacing, US spelling in comments or variable names. --- proofs/logic_monad.ml | 2 +- proofs/proof_global.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'proofs') diff --git a/proofs/logic_monad.ml b/proofs/logic_monad.ml index 81f02b66db..b9165aa812 100644 --- a/proofs/logic_monad.ml +++ b/proofs/logic_monad.ml @@ -188,7 +188,7 @@ struct shape of the monadic type is reminiscent of that of the continuation monad transformer. - The paper also contains the rational for the [split] abstraction. + The paper also contains the rationale for the [split] abstraction. An explanation of how to derive such a monad from mathematical principles can be found in "Kan Extensions for Program diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 028116049c..fcb706cc8d 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -94,7 +94,7 @@ val start_dependent_proof : val close_proof : keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof (* Intermediate step necessary to delegate the future. - * Both access the current proof state. The formes is supposed to be + * Both access the current proof state. The former is supposed to be * chained with a computation that completed the proof *) type closed_proof_output = (Term.constr * Declareops.side_effects) list * Evd.evar_universe_context -- cgit v1.2.3 From 4a76d2034983462175219426ec47c45a3c60d4fe Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 11 Oct 2015 14:47:52 +0200 Subject: Constraining refine to monotonic functions. --- proofs/proofview.ml | 9 +++++++-- proofs/proofview.mli | 4 ++-- 2 files changed, 9 insertions(+), 4 deletions(-) (limited to 'proofs') diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 11b7d07d05..f549913f2f 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -16,6 +16,7 @@ open Pp open Util open Proofview_monad +open Sigma.Notations (** Main state of tactics *) type proofview = Proofview_monad.proofview @@ -1031,7 +1032,7 @@ struct let prev_future_goals = Evd.future_goals sigma in let prev_principal_goal = Evd.principal_future_goal sigma in (** Create the refinement term *) - let (sigma, c) = f (Evd.reset_future_goals sigma) in + let (c, sigma) = Sigma.run (Evd.reset_future_goals sigma) f in let evs = Evd.future_goals sigma in let evkmain = Evd.principal_future_goal sigma in (** Check that the introduced evars are well-typed *) @@ -1074,7 +1075,11 @@ struct let refine_casted ?unsafe f = Goal.enter begin fun gl -> let concl = Goal.concl gl in let env = Goal.env gl in - let f h = let (h, c) = f h in with_type env h c concl in + let f = { run = fun h -> + let Sigma (c, h, p) = f.run h in + let sigma, c = with_type env (Sigma.to_evar_map h) c concl in + Sigma (c, Sigma.Unsafe.of_evar_map sigma, p) + } in refine ?unsafe f end end diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 98e1477ff1..04ca01ec4d 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -487,7 +487,7 @@ module Refine : sig (** {7 Refinement primitives} *) - val refine : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * Constr.t) -> unit tactic + val refine : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic (** In [refine ?unsafe t], [t] is a term with holes under some [evar_map] context. The term [t] is used as a partial solution for the current goal (refine is a goal-dependent tactic), the @@ -503,7 +503,7 @@ module Refine : sig (** [with_type env sigma c t] ensures that [c] is of type [t] inserting a coercion if needed. *) - val refine_casted : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map*Constr.t) -> unit tactic + val refine_casted : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic (** Like {!refine} except the refined term is coerced to the conclusion of the current goal. *) -- cgit v1.2.3 From 7d697193ab175b6bfa3c773880c0a06348449d19 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 18 Oct 2015 20:29:58 +0200 Subject: Making Evarutil.new_evar monotonous. --- proofs/clenv.ml | 9 +++++++-- proofs/proofview.ml | 4 +++- 2 files changed, 10 insertions(+), 3 deletions(-) (limited to 'proofs') diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 0697c94d74..ae790d9b82 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -24,6 +24,7 @@ open Pretype_errors open Evarutil open Unification open Misctypes +open Sigma.Notations (* Abbreviations *) @@ -335,7 +336,9 @@ let clenv_pose_metas_as_evars clenv dep_mvs = else let src = evar_source_of_meta mv clenv.evd in let src = adjust_meta_source clenv.evd mv src in - let (evd,evar) = new_evar (cl_env clenv) clenv.evd ~src ty in + let evd = Sigma.Unsafe.of_evar_map clenv.evd in + let Sigma (evar, evd, _) = new_evar (cl_env clenv) evd ~src ty in + let evd = Sigma.to_evar_map evd in let clenv = clenv_assign mv evar {clenv with evd=evd} in fold clenv mvs in fold clenv dep_mvs @@ -614,7 +617,9 @@ let make_evar_clause env sigma ?len t = | Cast (t, _, _) -> clrec (sigma, holes) n t | Prod (na, t1, t2) -> let store = Typeclasses.set_resolvable Evd.Store.empty false in - let sigma, ev = new_evar ~store env sigma t1 in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (ev, sigma, _) = new_evar ~store env sigma t1 in + let sigma = Sigma.to_evar_map sigma in let dep = dependent (mkRel 1) t2 in let hole = { hole_evar = ev; diff --git a/proofs/proofview.ml b/proofs/proofview.ml index f549913f2f..bc2cc3e913 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -65,7 +65,9 @@ let dependent_init = let rec aux = function | TNil sigma -> [], { solution = sigma; comb = []; } | TCons (env, sigma, typ, t) -> - let (sigma, econstr ) = Evarutil.new_evar env sigma ~src ~store typ in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (econstr, sigma, _) = Evarutil.new_evar env sigma ~src ~store typ in + let sigma = Sigma.to_evar_map sigma in let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in let (gl, _) = Term.destEvar econstr in let entry = (econstr, typ) :: ret in -- cgit v1.2.3 From 4edab6bff366492d3e96c2b561384568927e2b05 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 19 Oct 2015 11:20:15 +0200 Subject: Adding a monotonic variant of Goal.enter and Goal.nf_enter. --- proofs/proofview.ml | 61 ++++++++++++++++++++++++++++++++++++++++++---------- proofs/proofview.mli | 40 ++++++++++++++++++++++------------ 2 files changed, 76 insertions(+), 25 deletions(-) (limited to 'proofs') diff --git a/proofs/proofview.ml b/proofs/proofview.ml index bc2cc3e913..da9c4da9f9 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -892,17 +892,9 @@ end module UnsafeRepr = Proof.Unsafe -(** {7 Notations} *) - -module Notations = struct - let (>>=) = tclBIND - let (<*>) = tclTHEN - let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) -end - -open Notations - - +let (>>=) = tclBIND +let (<*>) = tclTHEN +let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) (** {6 Goal-dependent tactics} *) @@ -982,6 +974,43 @@ module Goal = struct end end + type 'a enter = + { enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + + let s_enter f = + InfoL.tag (Info.Dispatch) begin + iter_goal begin fun goal -> + Env.get >>= fun env -> + tclEVARMAP >>= fun sigma -> + try + let gl = gmake env sigma goal in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (tac, sigma, _) = f.enter gl sigma in + let sigma = Sigma.to_evar_map sigma in + tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) + with e when catchable_exception e -> + let (e, info) = Errors.push e in + tclZERO ~info e + end + end + + let nf_s_enter f = + InfoL.tag (Info.Dispatch) begin + iter_goal begin fun goal -> + Env.get >>= fun env -> + tclEVARMAP >>= fun sigma -> + try + let (gl, sigma) = nf_gmake env sigma goal in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (tac, sigma, _) = f.enter gl sigma in + let sigma = Sigma.to_evar_map sigma in + tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) + with e when catchable_exception e -> + let (e, info) = Errors.push e in + tclZERO ~info e + end + end + let goals = Env.get >>= fun env -> Pv.get >>= fun step -> @@ -1218,3 +1247,13 @@ module V82 = struct let (e, info) = Errors.push e in tclZERO ~info e end + +(** {7 Notations} *) + +module Notations = struct + let (>>=) = tclBIND + let (<*>) = tclTHEN + let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) + type 'a enter = 'a Goal.enter = + { enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } +end diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 04ca01ec4d..b565589eb7 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -414,20 +414,6 @@ sig val make : ('a, state, state, iexn) Logic_monad.BackState.t -> 'a tactic end -(** {7 Notations} *) - -module Notations : sig - - (** {!tclBIND} *) - val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic - (** {!tclTHEN} *) - val (<*>) : unit tactic -> 'a tactic -> 'a tactic - (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) - val (<+>) : 'a tactic -> 'a tactic -> 'a tactic - -end - - (** {6 Goal-dependent tactics} *) module Goal : sig @@ -468,6 +454,17 @@ module Goal : sig (** Like {!nf_enter}, but does not normalize the goal beforehand. *) val enter : ([ `LZ ] t -> unit tactic) -> unit tactic + type 'a enter = + { enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + + (** A variant of {!enter} allows to work with a monotonic state. The evarmap + returned by the argument is put back into the current state before firing + the returned tactic. *) + val s_enter : [ `LZ ] enter -> unit tactic + + (** Like {!s_enter}, but normalizes the goal beforehand. *) + val nf_s_enter : [ `NF ] enter -> unit tactic + (** Recover the list of current goals under focus, without evar-normalization *) val goals : [ `LZ ] t tactic list tactic @@ -583,3 +580,18 @@ module V82 : sig the monad. *) val wrap_exceptions : (unit -> 'a tactic) -> 'a tactic end + +(** {7 Notations} *) + +module Notations : sig + + (** {!tclBIND} *) + val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic + (** {!tclTHEN} *) + val (<*>) : unit tactic -> 'a tactic -> 'a tactic + (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) + val (<+>) : 'a tactic -> 'a tactic -> 'a tactic + + type 'a enter = 'a Goal.enter = + { enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } +end -- cgit v1.2.3 From 50a574f8b3e7f29550d7abf600d92eb43e7f8ef6 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Mon, 19 Oct 2015 18:12:27 +0200 Subject: Categorizing debug messages as such + NonLogical uses loggers. --- proofs/logic_monad.ml | 15 +++++++-------- proofs/logic_monad.mli | 9 +++++---- proofs/tactic_debug.ml | 6 +++--- 3 files changed, 15 insertions(+), 15 deletions(-) (limited to 'proofs') diff --git a/proofs/logic_monad.ml b/proofs/logic_monad.ml index b9165aa812..e3caa886a2 100644 --- a/proofs/logic_monad.ml +++ b/proofs/logic_monad.ml @@ -94,14 +94,6 @@ struct let print_char = fun c -> (); fun () -> print_char c - (** {!Pp.pp}. The buffer is also flushed. *) - let print_debug = fun s -> (); fun () -> try Pp.msg_info s; Pp.pp_flush () with e -> - let (e, info) = Errors.push e in raise ~info e () - - (** {!Pp.pp}. The buffer is also flushed. *) - let print = fun s -> (); fun () -> try Pp.msg_notice s; Pp.pp_flush () with e -> - let (e, info) = Errors.push e in raise ~info e () - let timeout = fun n t -> (); fun () -> Control.timeout n t (Exception Timeout) @@ -111,6 +103,13 @@ struct let (e, info) = Errors.push e in Util.iraise (Exception e, info) + (** Use the current logger. The buffer is also flushed. *) + let print_debug s = make (fun _ -> Pp.msg_info s;Pp.pp_flush ()) + let print_info s = make (fun _ -> Pp.msg_info s;Pp.pp_flush ()) + let print_warning s = make (fun _ -> Pp.msg_warning s;Pp.pp_flush ()) + let print_error s = make (fun _ -> Pp.msg_error s;Pp.pp_flush ()) + let print_notice s = make (fun _ -> Pp.msg_notice s;Pp.pp_flush ()) + let run = fun x -> try x () with Exception e as src -> let (src, info) = Errors.push src in diff --git a/proofs/logic_monad.mli b/proofs/logic_monad.mli index 511dd7a6ed..84ffda7533 100644 --- a/proofs/logic_monad.mli +++ b/proofs/logic_monad.mli @@ -55,12 +55,13 @@ module NonLogical : sig val read_line : string t val print_char : char -> unit t - (** {!Pp.pp}. The buffer is also flushed. *) - val print : Pp.std_ppcmds -> unit t - (* FIXME: shouldn't we have a logger instead? *) - (** {!Pp.pp}. The buffer is also flushed. *) + (** Loggers. The buffer is also flushed. *) val print_debug : Pp.std_ppcmds -> unit t + val print_warning : Pp.std_ppcmds -> unit t + val print_notice : Pp.std_ppcmds -> unit t + val print_info : Pp.std_ppcmds -> unit t + val print_error : Pp.std_ppcmds -> unit t (** [Pervasives.raise]. Except that exceptions are wrapped with {!Exception}. *) diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml index 667765dbf2..6d6215c521 100644 --- a/proofs/tactic_debug.ml +++ b/proofs/tactic_debug.ml @@ -33,7 +33,7 @@ let explain_logic_error = ref (fun e -> mt()) let explain_logic_error_no_anomaly = ref (fun e -> mt()) let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) -let msg_tac_notice s = Proofview.NonLogical.print (s++fnl()) +let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) (* Prints the goal *) @@ -122,7 +122,7 @@ let run ini = let open Proofview.NonLogical in if not ini then begin - Proofview.NonLogical.print (str"\b\r\b\r") >> + Proofview.NonLogical.print_notice (str"\b\r\b\r") >> !skipped >>= fun skipped -> msg_tac_debug (str "Executed expressions: " ++ int skipped ++ fnl()) end >> @@ -137,7 +137,7 @@ let rec prompt level = let runtrue = run true in begin let open Proofview.NonLogical in - Proofview.NonLogical.print (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >> + Proofview.NonLogical.print_notice (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >> let exit = (skip:=0) >> (skipped:=0) >> raise Sys.Break in Proofview.NonLogical.catch Proofview.NonLogical.read_line begin function (e, info) -> match e with -- cgit v1.2.3 From f5d8d305c34f9bab21436c765aeeb56a65005dfe Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 19 Oct 2015 22:52:36 +0200 Subject: Renaming Goal.enter field into s_enter. --- proofs/proofview.ml | 12 ++++++------ proofs/proofview.mli | 12 ++++++------ 2 files changed, 12 insertions(+), 12 deletions(-) (limited to 'proofs') diff --git a/proofs/proofview.ml b/proofs/proofview.ml index da9c4da9f9..7edbef57b4 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -974,8 +974,8 @@ module Goal = struct end end - type 'a enter = - { enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + type 'a s_enter = + { s_enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } let s_enter f = InfoL.tag (Info.Dispatch) begin @@ -985,7 +985,7 @@ module Goal = struct try let gl = gmake env sigma goal in let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (tac, sigma, _) = f.enter gl sigma in + let Sigma (tac, sigma, _) = f.s_enter gl sigma in let sigma = Sigma.to_evar_map sigma in tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) with e when catchable_exception e -> @@ -1002,7 +1002,7 @@ module Goal = struct try let (gl, sigma) = nf_gmake env sigma goal in let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (tac, sigma, _) = f.enter gl sigma in + let Sigma (tac, sigma, _) = f.s_enter gl sigma in let sigma = Sigma.to_evar_map sigma in tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) with e when catchable_exception e -> @@ -1254,6 +1254,6 @@ module Notations = struct let (>>=) = tclBIND let (<*>) = tclTHEN let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) - type 'a enter = 'a Goal.enter = - { enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + type 'a s_enter = 'a Goal.s_enter = + { s_enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } end diff --git a/proofs/proofview.mli b/proofs/proofview.mli index b565589eb7..a94610af47 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -454,16 +454,16 @@ module Goal : sig (** Like {!nf_enter}, but does not normalize the goal beforehand. *) val enter : ([ `LZ ] t -> unit tactic) -> unit tactic - type 'a enter = - { enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + type 'a s_enter = + { s_enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } (** A variant of {!enter} allows to work with a monotonic state. The evarmap returned by the argument is put back into the current state before firing the returned tactic. *) - val s_enter : [ `LZ ] enter -> unit tactic + val s_enter : [ `LZ ] s_enter -> unit tactic (** Like {!s_enter}, but normalizes the goal beforehand. *) - val nf_s_enter : [ `NF ] enter -> unit tactic + val nf_s_enter : [ `NF ] s_enter -> unit tactic (** Recover the list of current goals under focus, without evar-normalization *) val goals : [ `LZ ] t tactic list tactic @@ -592,6 +592,6 @@ module Notations : sig (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) val (<+>) : 'a tactic -> 'a tactic -> 'a tactic - type 'a enter = 'a Goal.enter = - { enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + type 'a s_enter = 'a Goal.s_enter = + { s_enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } end -- cgit v1.2.3 From cc42541eeaaec0371940e07efdb009a4ee74e468 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 20 Oct 2015 13:04:45 +0200 Subject: Boxing the Goal.enter primitive into a record type. --- proofs/clenvtac.ml | 10 +++++----- proofs/proofview.ml | 17 +++++++++++------ proofs/proofview.mli | 9 +++++++-- proofs/tactic_debug.ml | 5 +++-- 4 files changed, 26 insertions(+), 15 deletions(-) (limited to 'proofs') diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index f54d4c4470..65bd325362 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -16,7 +16,7 @@ open Logic open Reduction open Tacmach open Clenv - +open Proofview.Notations (* This function put casts around metavariables whose type could not be * infered by the refiner, that is head of applications, predicates and @@ -83,10 +83,10 @@ open Unification let dft = default_unify_flags let res_pf ?(with_evars=false) ?(with_classes=true) ?(flags=dft ()) clenv = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let clenv gl = clenv_unique_resolver ~flags clenv gl in clenv_refine with_evars ~with_classes (Tacmach.New.of_old clenv (Proofview.Goal.assume gl)) - end + end } (* [unifyTerms] et [unify] ne semble pas gérer les Meta, en particulier ne semblent pas vérifier que des instances différentes @@ -118,7 +118,7 @@ let fail_quick_unif_flags = { (* let unifyTerms m n = walking (fun wc -> fst (w_Unify CONV m n [] wc)) *) let unify ?(flags=fail_quick_unif_flags) m = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Tacmach.New.pf_env gl in let n = Tacmach.New.pf_nf_concl gl in let evd = clear_metas (Proofview.Goal.sigma gl) in @@ -126,4 +126,4 @@ let unify ?(flags=fail_quick_unif_flags) m = let evd' = w_unify env evd CONV ~flags m n in Proofview.Unsafe.tclEVARSADVANCE evd' with e when Errors.noncritical e -> Proofview.tclZERO e - end + end } diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 7edbef57b4..b8a58daeb2 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -915,6 +915,9 @@ module Goal = struct self : Evar.t ; (* for compatibility with old-style definitions *) } + type 'a enter = + { enter : 'a t -> unit tactic } + let assume (gl : 'a t) = (gl :> [ `NF ] t) let env { env=env } = env @@ -944,7 +947,7 @@ module Goal = struct tclEVARMAP >>= fun sigma -> try let (gl, sigma) = nf_gmake env sigma goal in - tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f gl)) + tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f.enter gl)) with e when catchable_exception e -> let (e, info) = Errors.push e in tclZERO ~info e @@ -962,7 +965,7 @@ module Goal = struct gmake_with info env sigma goal let enter f = - let f gl = InfoL.tag (Info.DBranch) (f gl) in + let f gl = InfoL.tag (Info.DBranch) (f.enter gl) in InfoL.tag (Info.Dispatch) begin iter_goal begin fun goal -> Env.get >>= fun env -> @@ -1054,7 +1057,7 @@ struct let (pr_constrv,pr_constr) = Hook.make ~default:(fun _env _sigma _c -> Pp.str"") () - let refine ?(unsafe = true) f = Goal.enter begin fun gl -> + let refine ?(unsafe = true) f = Goal.enter { Goal.enter = begin fun gl -> let sigma = Goal.sigma gl in let env = Goal.env gl in let concl = Goal.concl gl in @@ -1091,7 +1094,7 @@ struct let open Proof in InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"refine"++spc()++ Hook.get pr_constrv env sigma c)))) >> Pv.set { solution = sigma; comb; } - end + end } (** Useful definitions *) @@ -1103,7 +1106,7 @@ struct in evd , j'.Environ.uj_val - let refine_casted ?unsafe f = Goal.enter begin fun gl -> + let refine_casted ?unsafe f = Goal.enter { Goal.enter = begin fun gl -> let concl = Goal.concl gl in let env = Goal.env gl in let f = { run = fun h -> @@ -1112,7 +1115,7 @@ struct Sigma (c, Sigma.Unsafe.of_evar_map sigma, p) } in refine ?unsafe f - end + end } end @@ -1254,6 +1257,8 @@ module Notations = struct let (>>=) = tclBIND let (<*>) = tclTHEN let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) + type 'a enter = 'a Goal.enter = + { enter : 'a Goal.t -> unit tactic } type 'a s_enter = 'a Goal.s_enter = { s_enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } end diff --git a/proofs/proofview.mli b/proofs/proofview.mli index a94610af47..1616782e54 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -445,14 +445,17 @@ module Goal : sig normalised. *) val raw_concl : 'a t -> Term.constr + type 'a enter = + { enter : 'a t -> unit tactic } + (** [nf_enter t] applies the goal-dependent tactic [t] in each goal independently, in the manner of {!tclINDEPENDENT} except that the current goal is also given as an argument to [t]. The goal is normalised with respect to evars. *) - val nf_enter : ([ `NF ] t -> unit tactic) -> unit tactic + val nf_enter : [ `NF ] enter -> unit tactic (** Like {!nf_enter}, but does not normalize the goal beforehand. *) - val enter : ([ `LZ ] t -> unit tactic) -> unit tactic + val enter : [ `LZ ] enter -> unit tactic type 'a s_enter = { s_enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } @@ -592,6 +595,8 @@ module Notations : sig (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) val (<+>) : 'a tactic -> 'a tactic -> 'a tactic + type 'a enter = 'a Goal.enter = + { enter : 'a Goal.t -> unit tactic } type 'a s_enter = 'a Goal.s_enter = { s_enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } end diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml index 6d6215c521..fb23a28feb 100644 --- a/proofs/tactic_debug.ml +++ b/proofs/tactic_debug.ml @@ -12,6 +12,7 @@ open Pp open Tacexpr open Termops open Nameops +open Proofview.Notations let (prtac, tactic_printer) = Hook.make () let (prmatchpatt, match_pattern_printer) = Hook.make () @@ -47,10 +48,10 @@ let db_pr_goal gl = str" " ++ pc) ++ fnl () let db_pr_goal = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let pg = db_pr_goal gl in Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) - end + end } (* Prints the commands *) -- cgit v1.2.3 From 4cc1714ac9b0944b6203c23af8c46145e7239ad3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 20 Oct 2015 14:45:31 +0200 Subject: Indexing Proofview.goals with a stage. This is not perfect though, some primitives are unsound, and some higher-order API should use polymorphic functions so as not to depend on a given level. --- proofs/proofview.ml | 22 +++++++++-------- proofs/proofview.mli | 68 ++++++++++++++++++++++++++++++---------------------- proofs/tacmach.ml | 2 +- proofs/tacmach.mli | 45 +++++++++++++++++----------------- 4 files changed, 75 insertions(+), 62 deletions(-) (limited to 'proofs') diff --git a/proofs/proofview.ml b/proofs/proofview.ml index b8a58daeb2..826b4772a0 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -908,17 +908,17 @@ let catchable_exception = function module Goal = struct - type 'a t = { + type ('a, 'r) t = { env : Environ.env; sigma : Evd.evar_map; concl : Term.constr ; self : Evar.t ; (* for compatibility with old-style definitions *) } - type 'a enter = - { enter : 'a t -> unit tactic } + type ('a, 'b) enter = + { enter : 'r. ('a, 'r) t -> 'b } - let assume (gl : 'a t) = (gl :> [ `NF ] t) + let assume (gl : ('a, 'r) t) = (gl :> ([ `NF ], 'r) t) let env { env=env } = env let sigma { sigma=sigma } = sigma @@ -977,8 +977,8 @@ module Goal = struct end end - type 'a s_enter = - { s_enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + type ('a, 'b) s_enter = + { s_enter : 'r. ('a, 'r) t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } let s_enter f = InfoL.tag (Info.Dispatch) begin @@ -1033,6 +1033,8 @@ module Goal = struct (* compatibility *) let goal { self=self } = self + let lift (gl : ('a, 'r) t) _ = (gl :> ('a, 's) t) + end @@ -1257,8 +1259,8 @@ module Notations = struct let (>>=) = tclBIND let (<*>) = tclTHEN let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) - type 'a enter = 'a Goal.enter = - { enter : 'a Goal.t -> unit tactic } - type 'a s_enter = 'a Goal.s_enter = - { s_enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + type ('a, 'b) enter = ('a, 'b) Goal.enter = + { enter : 'r. ('a, 'r) Goal.t -> 'b } + type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = + { s_enter : 'r. ('a, 'r) Goal.t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } end diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 1616782e54..5c97ada344 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -418,61 +418,71 @@ end module Goal : sig - (** The type of goals. The parameter type is a phantom argument indicating - whether the data contained in the goal has been normalized w.r.t. the - current sigma. If it is the case, it is flagged [ `NF ]. You may still - access the un-normalized data using {!assume} if you known you do not rely - on the assumption of being normalized, at your own risk. *) - type 'a t + (** Type of goals. + + The first parameter type is a phantom argument indicating whether the data + contained in the goal has been normalized w.r.t. the current sigma. If it + is the case, it is flagged [ `NF ]. You may still access the un-normalized + data using {!assume} if you known you do not rely on the assumption of + being normalized, at your own risk. + + The second parameter is a stage indicating where the goal belongs. See + module {!Sigma}. + *) + type ('a, 'r) t (** Assume that you do not need the goal to be normalized. *) - val assume : 'a t -> [ `NF ] t + val assume : ('a, 'r) t -> ([ `NF ], 'r) t (** Normalises the argument goal. *) - val normalize : 'a t -> [ `NF ] t tactic + val normalize : ('a, 'r) t -> ([ `NF ], 'r) t tactic (** [concl], [hyps], [env] and [sigma] given a goal [gl] return respectively the conclusion of [gl], the hypotheses of [gl], the environment of [gl] (i.e. the global environment and the hypotheses) and the current evar map. *) - val concl : [ `NF ] t -> Term.constr - val hyps : [ `NF ] t -> Context.named_context - val env : 'a t -> Environ.env - val sigma : 'a t -> Evd.evar_map - val extra : 'a t -> Evd.Store.t + val concl : ([ `NF ], 'r) t -> Term.constr + val hyps : ([ `NF ], 'r) t -> Context.named_context + val env : ('a, 'r) t -> Environ.env + val sigma : ('a, 'r) t -> Evd.evar_map + val extra : ('a, 'r) t -> Evd.Store.t (** Returns the goal's conclusion even if the goal is not normalised. *) - val raw_concl : 'a t -> Term.constr + val raw_concl : ('a, 'r) t -> Term.constr - type 'a enter = - { enter : 'a t -> unit tactic } + type ('a, 'b) enter = + { enter : 'r. ('a, 'r) t -> 'b } (** [nf_enter t] applies the goal-dependent tactic [t] in each goal independently, in the manner of {!tclINDEPENDENT} except that the current goal is also given as an argument to [t]. The goal is normalised with respect to evars. *) - val nf_enter : [ `NF ] enter -> unit tactic + val nf_enter : ([ `NF ], unit tactic) enter -> unit tactic (** Like {!nf_enter}, but does not normalize the goal beforehand. *) - val enter : [ `LZ ] enter -> unit tactic + val enter : ([ `LZ ], unit tactic) enter -> unit tactic - type 'a s_enter = - { s_enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + type ('a, 'b) s_enter = + { s_enter : 'r. ('a, 'r) t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } (** A variant of {!enter} allows to work with a monotonic state. The evarmap returned by the argument is put back into the current state before firing the returned tactic. *) - val s_enter : [ `LZ ] s_enter -> unit tactic + val s_enter : ([ `LZ ], unit tactic) s_enter -> unit tactic (** Like {!s_enter}, but normalizes the goal beforehand. *) - val nf_s_enter : [ `NF ] s_enter -> unit tactic + val nf_s_enter : ([ `NF ], unit tactic) s_enter -> unit tactic - (** Recover the list of current goals under focus, without evar-normalization *) - val goals : [ `LZ ] t tactic list tactic + (** Recover the list of current goals under focus, without evar-normalization. + FIXME: encapsulate the level in an existential type. *) + val goals : ([ `LZ ], 'r) t tactic list tactic (** Compatibility: avoid if possible *) - val goal : [ `NF ] t -> Evar.t + val goal : ([ `NF ], 'r) t -> Evar.t + + (** Every goal is valid at a later stage. FIXME: take a later evarmap *) + val lift : ('a, 'r) t -> ('r, 's) Sigma.le -> ('a, 's) t end @@ -595,8 +605,8 @@ module Notations : sig (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) val (<+>) : 'a tactic -> 'a tactic -> 'a tactic - type 'a enter = 'a Goal.enter = - { enter : 'a Goal.t -> unit tactic } - type 'a s_enter = 'a Goal.s_enter = - { s_enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + type ('a, 'b) enter = ('a, 'b) Goal.enter = + { enter : 'r. ('a, 'r) Goal.t -> 'b } + type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = + { s_enter : 'r. ('a, 'r) Goal.t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } end diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 4238d1e372..8af28b6ab1 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -212,7 +212,7 @@ module New = struct let hyps = Proofview.Goal.hyps gl in List.hd hyps - let pf_nf_concl (gl : [ `LZ ] Proofview.Goal.t) = + let pf_nf_concl (gl : ([ `LZ ], 'r) Proofview.Goal.t) = (** We normalize the conclusion just after *) let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index a0e1a01577..3ed6a2eeb1 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -106,36 +106,37 @@ val pr_glls : goal list sigma -> Pp.std_ppcmds (* Variants of [Tacmach] functions built with the new proof engine *) module New : sig - val pf_apply : (env -> evar_map -> 'a) -> 'b Proofview.Goal.t -> 'a - val pf_global : identifier -> 'a Proofview.Goal.t -> constr - val of_old : (Proof_type.goal Evd.sigma -> 'a) -> [ `NF ] Proofview.Goal.t -> 'a + val pf_apply : (env -> evar_map -> 'a) -> ('b, 'r) Proofview.Goal.t -> 'a + val pf_global : identifier -> ('a, 'r) Proofview.Goal.t -> constr + (** FIXME: encapsulate the level in an existential type. *) + val of_old : (Proof_type.goal Evd.sigma -> 'a) -> ([ `NF ], 'r) Proofview.Goal.t -> 'a - val pf_env : 'a Proofview.Goal.t -> Environ.env - val pf_concl : [ `NF ] Proofview.Goal.t -> types + val pf_env : ('a, 'r) Proofview.Goal.t -> Environ.env + val pf_concl : ([ `NF ], 'r) Proofview.Goal.t -> types - val pf_unsafe_type_of : 'a Proofview.Goal.t -> Term.constr -> Term.types - val pf_type_of : 'a Proofview.Goal.t -> Term.constr -> evar_map * Term.types - val pf_conv_x : 'a Proofview.Goal.t -> Term.constr -> Term.constr -> bool + val pf_unsafe_type_of : ('a, 'r) Proofview.Goal.t -> Term.constr -> Term.types + val pf_type_of : ('a, 'r) Proofview.Goal.t -> Term.constr -> evar_map * Term.types + val pf_conv_x : ('a, 'r) Proofview.Goal.t -> Term.constr -> Term.constr -> bool - val pf_get_new_id : identifier -> [ `NF ] Proofview.Goal.t -> identifier - val pf_ids_of_hyps : 'a Proofview.Goal.t -> identifier list - val pf_hyps_types : 'a Proofview.Goal.t -> (identifier * types) list + val pf_get_new_id : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> identifier + val pf_ids_of_hyps : ('a, 'r) Proofview.Goal.t -> identifier list + val pf_hyps_types : ('a, 'r) Proofview.Goal.t -> (identifier * types) list - val pf_get_hyp : identifier -> [ `NF ] Proofview.Goal.t -> named_declaration - val pf_get_hyp_typ : identifier -> [ `NF ] Proofview.Goal.t -> types - val pf_last_hyp : [ `NF ] Proofview.Goal.t -> named_declaration + val pf_get_hyp : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> named_declaration + val pf_get_hyp_typ : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> types + val pf_last_hyp : ([ `NF ], 'r) Proofview.Goal.t -> named_declaration - val pf_nf_concl : [ `LZ ] Proofview.Goal.t -> types - val pf_reduce_to_quantified_ind : 'a Proofview.Goal.t -> types -> pinductive * types + val pf_nf_concl : ([ `LZ ], 'r) Proofview.Goal.t -> types + val pf_reduce_to_quantified_ind : ('a, 'r) Proofview.Goal.t -> types -> pinductive * types - val pf_hnf_constr : 'a Proofview.Goal.t -> constr -> types - val pf_hnf_type_of : 'a Proofview.Goal.t -> constr -> types + val pf_hnf_constr : ('a, 'r) Proofview.Goal.t -> constr -> types + val pf_hnf_type_of : ('a, 'r) Proofview.Goal.t -> constr -> types - val pf_whd_betadeltaiota : 'a Proofview.Goal.t -> constr -> constr - val pf_compute : 'a Proofview.Goal.t -> constr -> constr + val pf_whd_betadeltaiota : ('a, 'r) Proofview.Goal.t -> constr -> constr + val pf_compute : ('a, 'r) Proofview.Goal.t -> constr -> constr - val pf_matches : 'a Proofview.Goal.t -> constr_pattern -> constr -> patvar_map + val pf_matches : ('a, 'r) Proofview.Goal.t -> constr_pattern -> constr -> patvar_map - val pf_nf_evar : 'a Proofview.Goal.t -> constr -> constr + val pf_nf_evar : ('a, 'r) Proofview.Goal.t -> constr -> constr end -- cgit v1.2.3 From 2d747797c427818cdf85d0a0d701c7c9b0106b82 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 20 Oct 2015 16:12:39 +0200 Subject: Proofview.Goal.sigma returns an indexed evarmap. --- proofs/clenvtac.ml | 2 +- proofs/proofview.ml | 3 ++- proofs/proofview.mli | 2 +- proofs/tacmach.ml | 12 ++++++++---- proofs/tacmach.mli | 1 + 5 files changed, 13 insertions(+), 7 deletions(-) (limited to 'proofs') diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 65bd325362..894b290f14 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -121,7 +121,7 @@ let unify ?(flags=fail_quick_unif_flags) m = Proofview.Goal.enter { enter = begin fun gl -> let env = Tacmach.New.pf_env gl in let n = Tacmach.New.pf_nf_concl gl in - let evd = clear_metas (Proofview.Goal.sigma gl) in + let evd = clear_metas (Tacmach.New.project gl) in try let evd' = w_unify env evd CONV ~flags m n in Proofview.Unsafe.tclEVARSADVANCE evd' diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 826b4772a0..bded518e78 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -921,7 +921,7 @@ module Goal = struct let assume (gl : ('a, 'r) t) = (gl :> ([ `NF ], 'r) t) let env { env=env } = env - let sigma { sigma=sigma } = sigma + let sigma { sigma=sigma } = Sigma.Unsafe.of_evar_map sigma let hyps { env=env } = Environ.named_context env let concl { concl=concl } = concl let extra { sigma=sigma; self=self } = Goal.V82.extra sigma self @@ -1061,6 +1061,7 @@ struct let refine ?(unsafe = true) f = Goal.enter { Goal.enter = begin fun gl -> let sigma = Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in let env = Goal.env gl in let concl = Goal.concl gl in (** Save the [future_goals] state to restore them after the diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 5c97ada344..0b6c147f92 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -444,7 +444,7 @@ module Goal : sig val concl : ([ `NF ], 'r) t -> Term.constr val hyps : ([ `NF ], 'r) t -> Context.named_context val env : ('a, 'r) t -> Environ.env - val sigma : ('a, 'r) t -> Evd.evar_map + val sigma : ('a, 'r) t -> 'r Sigma.t val extra : ('a, 'r) t -> Evd.Store.t (** Returns the goal's conclusion even if the goal is not diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 8af28b6ab1..57c60cbeed 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -158,11 +158,15 @@ let pr_glls glls = (* Variants of [Tacmach] functions built with the new proof engine *) module New = struct + let project gl = + let sigma = Proofview.Goal.sigma gl in + Sigma.to_evar_map sigma + let pf_apply f gl = - f (Proofview.Goal.env gl) (Proofview.Goal.sigma gl) + f (Proofview.Goal.env gl) (project gl) let of_old f gl = - f { Evd.it = Proofview.Goal.goal gl ; sigma = Proofview.Goal.sigma gl } + f { Evd.it = Proofview.Goal.goal gl ; sigma = project gl; } let pf_global id gl = (** We only check for the existence of an [id] in [hyps] *) @@ -216,7 +220,7 @@ module New = struct (** We normalize the conclusion just after *) let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = project gl in nf_evar sigma concl let pf_whd_betadeltaiota gl t = pf_apply whd_betadeltaiota gl t @@ -235,6 +239,6 @@ module New = struct let pf_whd_betadeltaiota gl t = pf_apply whd_betadeltaiota gl t let pf_compute gl t = pf_apply compute gl t - let pf_nf_evar gl t = nf_evar (Proofview.Goal.sigma gl) t + let pf_nf_evar gl t = nf_evar (project gl) t end diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 3ed6a2eeb1..c45fd250cb 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -111,6 +111,7 @@ module New : sig (** FIXME: encapsulate the level in an existential type. *) val of_old : (Proof_type.goal Evd.sigma -> 'a) -> ([ `NF ], 'r) Proofview.Goal.t -> 'a + val project : ('a, 'r) Proofview.Goal.t -> Evd.evar_map val pf_env : ('a, 'r) Proofview.Goal.t -> Environ.env val pf_concl : ([ `NF ], 'r) Proofview.Goal.t -> types -- cgit v1.2.3 From ae7e8f8f66359a46e165e1eae6cf15eb09fd66de Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Wed, 21 Oct 2015 10:59:36 +0200 Subject: Fixed (and changed) infoH. The detection of new hypothesis was bugged. Now infoH behaves like "Show Intros": it performs tac, grab information on hypothesis names but let the state unchanged. FTR: infoH is fundamentally unable to be correct in presence of tactics that delete hypothesis and reuse there names. Like destruct or induction. Fortunately destruct and induction now come with a variant asking that the hypothesis is not deleted. To guess for the right as-close for [induction H], do [infoH induction !H]. This will not create the same names as induction would have by itself but at least there will be the right number of hypothesis. --- proofs/refiner.ml | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) (limited to 'proofs') diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 974fa212f1..ba62b2cb2d 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -186,10 +186,15 @@ let tclNOTSAMEGOAL (tac : tactic) goal = (str"Tactic generated a subgoal identical to the original goal.") else rslt -(* Execute tac and show the names of hypothesis create by tac in - the "as" format. The resulting goals are printed *after* the - as-expression, which forces pg to some gymnastic. TODO: Have - something similar (better?) in the xml protocol. *) +(* Execute tac, show the names of new hypothesis names created by tac + in the "as" format and then forget everything. From the logical + point of view [tclSHOWHYPS tac] is therefore equivalent to idtac, + except that it takes the time and memory of tac and prints "as" + information). The resulting (unchanged) goals are printed *after* + the as-expression, which forces pg to some gymnastic. + TODO: Have something similar (better?) in the xml protocol. + NOTE: some tactics delete hypothesis and reuse names (induction, + destruct), this is not detected by this tactical. *) let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) :Proof_type.goal list Evd.sigma = let oldhyps:Context.named_context = pf_hyps goal in @@ -197,9 +202,10 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) let { it = gls; sigma = sigma; } = rslt in let hyps:Context.named_context list = List.map (fun gl -> pf_hyps { it = gl; sigma=sigma; }) gls in + let cmp (i1, c1, t1) (i2, c2, t2) = Names.Id.equal i1 i2 in let newhyps = List.map - (fun hypl -> List.subtract Context.eq_named_declaration hypl oldhyps) + (fun hypl -> List.subtract cmp hypl oldhyps) hyps in let emacs_str s = @@ -215,7 +221,7 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) pp (str (emacs_str "") ++ (hov 0 (str s)) ++ (str (emacs_str "")) ++ fnl()); - rslt;; + tclIDTAC goal;; let catch_failerror (e, info) = -- cgit v1.2.3 From 908dcd613b12645f3b62bf44c2696b80a0b16940 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 28 Oct 2015 16:46:42 +0100 Subject: Avoid type checking private_constants (side_eff) again during Qed (#4357). Side effects are now an opaque data type, called private_constant, you can only obtain from safe_typing. When add_constant is called on a definition_entry that contains private constants, they are either - inlined in the main proof term but not re-checked - declared globally without re-checking them As a safety measure, the opaque data type contains a pointer to the revstruct (an internal field of safe_env that changes every time a new constant is added), and such pointer is compared with the current value store in safe_env when the private_constant is inlined. Only when the comparison is successful the private_constant is not re-checked. Otherwise else it is. In short, we accept into the kernel private constant only when they arrive in the very same order and on top of the very same env they arrived when we fist checked them. Note: private_constants produced by workers never pass the safety measure (the revstruct pointer is an Ephemeron). Sending back the entire revstruct is possible but: 1. we lack a way to quickly compare two revstructs, 2. it can be large. --- proofs/pfedit.ml | 10 +++++++--- proofs/pfedit.mli | 6 +++--- proofs/proof_global.ml | 9 +++++---- proofs/proof_global.mli | 4 ++-- proofs/proofview.mli | 2 +- 5 files changed, 18 insertions(+), 13 deletions(-) (limited to 'proofs') diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 00ef8ecafd..02dbd1fdcb 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -150,10 +150,14 @@ let build_by_tactic ?(side_eff=true) env ctx ?(poly=false) typ tac = let sign = val_of_named_context (named_context env) in let gk = Global, poly, Proof Theorem in let ce, status, univs = build_constant_by_tactic id ctx sign ~goal_kind:gk typ tac in - let ce = if side_eff then Term_typing.handle_entry_side_effects env ce else { ce with const_entry_body = Future.chain ~pure:true ce.const_entry_body (fun (pt, _) -> pt, Declareops.no_seff) } in + let ce = + if side_eff then Safe_typing.inline_private_constants_in_definition_entry env ce + else { ce with + const_entry_body = Future.chain ~pure:true ce.const_entry_body + (fun (pt, _) -> pt, Safe_typing.empty_private_constants) } in let (cb, ctx), se = Future.force ce.const_entry_body in let univs' = Evd.merge_context_set Evd.univ_rigid (Evd.from_ctx univs) ctx in - assert(Declareops.side_effects_is_empty se); + assert(Safe_typing.empty_private_constants = se); cb, status, Evd.evar_universe_context univs' let refine_by_tactic env sigma ty tac = @@ -188,7 +192,7 @@ let refine_by_tactic env sigma ty tac = other goals that were already present during its invocation, so that those goals rely on effects that are not present anymore. Hopefully, this hack will work in most cases. *) - let ans = Term_typing.handle_side_effects env ans neff in + let ans = Safe_typing.inline_private_constants_in_constr env ans neff in ans, sigma (**********************************************************************) diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index b1fba132d9..fc521ea432 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -69,11 +69,11 @@ val start_proof : val cook_this_proof : Proof_global.proof_object -> (Id.t * - (Entries.definition_entry * Proof_global.proof_universes * goal_kind)) + (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * goal_kind)) val cook_proof : unit -> (Id.t * - (Entries.definition_entry * Proof_global.proof_universes * goal_kind)) + (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * goal_kind)) (** {6 ... } *) (** [get_pftreestate ()] returns the current focused pending proof. @@ -152,7 +152,7 @@ val instantiate_nth_evar_com : int -> Constrexpr.constr_expr -> unit val build_constant_by_tactic : Id.t -> Evd.evar_universe_context -> named_context_val -> ?goal_kind:goal_kind -> types -> unit Proofview.tactic -> - Entries.definition_entry * bool * Evd.evar_universe_context + Safe_typing.private_constants Entries.definition_entry * bool * Evd.evar_universe_context val build_by_tactic : ?side_eff:bool -> env -> Evd.evar_universe_context -> ?poly:polymorphic -> types -> unit Proofview.tactic -> diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index a0ead42ef3..809ed41c7e 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -67,7 +67,7 @@ type proof_universes = Evd.evar_universe_context type proof_object = { id : Names.Id.t; - entries : Entries.definition_entry list; + entries : Safe_typing.private_constants Entries.definition_entry list; persistence : Decl_kinds.goal_kind; universes: proof_universes; (* constraints : Univ.constraints; *) @@ -315,13 +315,14 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = let open Universes in let body = c in let typ = - if not (keep_body_ucst_separate || not (Declareops.side_effects_is_empty eff)) then + if not (keep_body_ucst_separate || not (Safe_typing.empty_private_constants = eff)) then nf t else t in let used_univs_body = Universes.universes_of_constr body in let used_univs_typ = Universes.universes_of_constr typ in - if keep_body_ucst_separate || not (Declareops.side_effects_is_empty eff) then + if keep_body_ucst_separate || + not (Safe_typing.empty_private_constants = eff) then let initunivs = Evd.evar_context_universe_context initial_euctx in let ctx = Evd.evar_universe_context_set initunivs universes in (* For vi2vo compilation proofs are computed now but we need to @@ -365,7 +366,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = { id = pid; entries = entries; persistence = strength; universes = universes }, fun pr_ending -> Ephemeron.get terminator pr_ending -type closed_proof_output = (Term.constr * Declareops.side_effects) list * Evd.evar_universe_context +type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context let return_proof ?(allow_partial=false) () = let { pid; proof; strength = (_,poly,_) } = cur_pstate () in diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index fcb706cc8d..f8615e8499 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -58,7 +58,7 @@ type lemma_possible_guards = int list list type proof_universes = Evd.evar_universe_context type proof_object = { id : Names.Id.t; - entries : Entries.definition_entry list; + entries : Safe_typing.private_constants Entries.definition_entry list; persistence : Decl_kinds.goal_kind; universes: proof_universes; (* constraints : Univ.constraints; *) @@ -97,7 +97,7 @@ val close_proof : keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof * Both access the current proof state. The former is supposed to be * chained with a computation that completed the proof *) -type closed_proof_output = (Term.constr * Declareops.side_effects) list * Evd.evar_universe_context +type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context (* If allow_partial is set (default no) then an incomplete proof * is allowed (no error), and a warn is given if the proof is complete. *) diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 5a9e7f39f0..927df33a0c 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -336,7 +336,7 @@ val tclENV : Environ.env tactic (** {7 Put-like primitives} *) (** [tclEFFECTS eff] add the effects [eff] to the current state. *) -val tclEFFECTS : Declareops.side_effects -> unit tactic +val tclEFFECTS : Safe_typing.private_constants -> unit tactic (** [mark_as_unsafe] declares the current tactic is unsafe. *) val mark_as_unsafe : unit tactic -- cgit v1.2.3 From 250df8586a776eaadc3553b5ceef98d3696fffdb Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 29 Oct 2015 19:14:51 +0100 Subject: Removing the evar_map argument from s_enter. --- proofs/proofview.ml | 10 ++++------ proofs/proofview.mli | 4 ++-- 2 files changed, 6 insertions(+), 8 deletions(-) (limited to 'proofs') diff --git a/proofs/proofview.ml b/proofs/proofview.ml index bded518e78..96ba88233e 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -978,7 +978,7 @@ module Goal = struct end type ('a, 'b) s_enter = - { s_enter : 'r. ('a, 'r) t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } + { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } let s_enter f = InfoL.tag (Info.Dispatch) begin @@ -987,8 +987,7 @@ module Goal = struct tclEVARMAP >>= fun sigma -> try let gl = gmake env sigma goal in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (tac, sigma, _) = f.s_enter gl sigma in + let Sigma (tac, sigma, _) = f.s_enter gl in let sigma = Sigma.to_evar_map sigma in tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) with e when catchable_exception e -> @@ -1004,8 +1003,7 @@ module Goal = struct tclEVARMAP >>= fun sigma -> try let (gl, sigma) = nf_gmake env sigma goal in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (tac, sigma, _) = f.s_enter gl sigma in + let Sigma (tac, sigma, _) = f.s_enter gl in let sigma = Sigma.to_evar_map sigma in tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) with e when catchable_exception e -> @@ -1263,5 +1261,5 @@ module Notations = struct type ('a, 'b) enter = ('a, 'b) Goal.enter = { enter : 'r. ('a, 'r) Goal.t -> 'b } type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = - { s_enter : 'r. ('a, 'r) Goal.t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } + { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } end diff --git a/proofs/proofview.mli b/proofs/proofview.mli index aafd4c5759..66603b9764 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -464,7 +464,7 @@ module Goal : sig val enter : ([ `LZ ], unit tactic) enter -> unit tactic type ('a, 'b) s_enter = - { s_enter : 'r. ('a, 'r) t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } + { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } (** A variant of {!enter} allows to work with a monotonic state. The evarmap returned by the argument is put back into the current state before firing @@ -608,5 +608,5 @@ module Notations : sig type ('a, 'b) enter = ('a, 'b) Goal.enter = { enter : 'r. ('a, 'r) Goal.t -> 'b } type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = - { s_enter : 'r. ('a, 'r) Goal.t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } + { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } end -- cgit v1.2.3 From a3a17b514a2ffaba54cd182fdf27b7e84366ab44 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 29 Oct 2015 15:11:29 -0400 Subject: Handle side-effects of Vernacular commands inside proofs better, so that universes are declared correctly in the enclosing proofs evar_map's. --- proofs/proof_global.ml | 6 ++++++ proofs/proof_global.mli | 5 +++++ 2 files changed, 11 insertions(+) (limited to 'proofs') diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 809ed41c7e..c303f486c5 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -695,3 +695,9 @@ let copy_terminators ~src ~tgt = assert(List.length src = List.length tgt); List.map2 (fun op p -> { p with terminator = op.terminator }) src tgt +let update_global_env () = + with_current_proof (fun _ p -> + Proof.in_proof p (fun sigma -> + let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in + let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac p in + (p, ()))) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index f8615e8499..a22545080b 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -89,6 +89,11 @@ val start_dependent_proof : Names.Id.t -> Decl_kinds.goal_kind -> Proofview.telescope -> proof_terminator -> unit +(** Update the proofs global environment after a side-effecting command + (e.g. a sublemma definition) has been run inside it. Assumes + there_are_pending_proofs. *) +val update_global_env : unit -> unit + (* Takes a function to add to the exceptions data relative to the state in which the proof was built *) val close_proof : keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof -- cgit v1.2.3 From 69be6a29cf9f774cb4afe94d76b157ba50984c1d Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 31 Oct 2015 15:12:02 +0100 Subject: Made that the syntax [id]:tac also applies to the shelve, which is after all its main interest! --- proofs/proofview.ml | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) (limited to 'proofs') diff --git a/proofs/proofview.ml b/proofs/proofview.ml index de6d605670..4fc0c164e3 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -384,20 +384,23 @@ let tclTRYFOCUS i j t = tclFOCUS_gen (tclUNIT ()) i j t let tclFOCUSID id t = let open Proof in Pv.get >>= fun initial -> - let rec aux n = function - | [] -> tclZERO (NoSuchGoals 1) - | g::l -> - if Names.Id.equal (Evd.evar_ident g initial.solution) id then - let (focused,context) = focus n n initial in - Pv.set focused >> - t >>= fun result -> - Pv.modify (fun next -> unfocus context next) >> - return result - else - aux (n+1) l in - aux 1 initial.comb - - + try + let ev = Evd.evar_key id initial.solution in + try + let n = CList.index Evar.equal ev initial.comb in + (* goal is already under focus *) + let (focused,context) = focus n n initial in + Pv.set focused >> + t >>= fun result -> + Pv.modify (fun next -> unfocus context next) >> + return result + with Not_found -> + (* otherwise, save current focus and work purely on the shelve *) + Comb.set [ev] >> + t >>= fun result -> + Comb.set initial.comb >> + return result + with Not_found -> tclZERO (NoSuchGoals 1) (** {7 Dispatching on goals} *) -- cgit v1.2.3 From b30ca8ac9e0225e6505fea0004ea37e7649c9cb6 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 3 Nov 2015 17:25:49 -0500 Subject: Fix bug in proofs/logic.ml type_of_global_reference_knowing_conclusion is buggy in general. --- proofs/logic.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'proofs') diff --git a/proofs/logic.ml b/proofs/logic.ml index 5c48995fc7..3273c95728 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -356,9 +356,11 @@ let rec mk_refgoals sigma goal goalacc conclty trm = | App (f,l) -> let (acc',hdty,sigma,applicand) = if is_template_polymorphic env f then - let sigma, ty = + let ty = (* Template sort-polymorphism of definition and inductive types *) - type_of_global_reference_knowing_conclusion env sigma f conclty + let firstmeta = Array.findi (fun i x -> occur_meta x) l in + let args, _ = Option.cata (fun i -> CArray.chop i l) (l, [||]) firstmeta in + type_of_global_reference_knowing_parameters env sigma f args in goalacc, ty, sigma, f else -- cgit v1.2.3 From 479d4cd6e9934a47debf6201fccf7ebb1aea1b09 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 7 Nov 2015 22:21:10 +0100 Subject: Implementing assert and cut with LetIn rather than using a beta-redex. Hopefully, it will provide with nicer proof terms, in combination with the commit printing the type of LetIn when the defined term is a proof. --- proofs/logic.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'proofs') diff --git a/proofs/logic.ml b/proofs/logic.ml index a38a36bdcc..e80f5a64c7 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -532,7 +532,7 @@ let prim_refiner r sigma goal = push_named_context_val (id,None,t) sign,t,cl,sigma) in let (sg2,ev2,sigma) = Goal.V82.mk_goal sigma sign cl (Goal.V82.extra sigma goal) in - let oterm = Term.mkApp (mkNamedLambda id t ev2 , [| ev1 |]) in + let oterm = Term.mkNamedLetIn id ev1 t ev2 in let sigma = Goal.V82.partial_solution_to sigma goal sg2 oterm in if b then ([sg1;sg2],sigma) else ([sg2;sg1],sigma) -- cgit v1.2.3 From 0c11bc39927c7756a0e3c3a6c445f20d0daaad7f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 12 Nov 2015 14:14:38 +0100 Subject: Fix bug #4412: [rewrite] (setoid_rewrite?) creates ill-typed terms. We retypecheck the hypotheses introduced by the refine primitive instead of blindly trusting them when the unsafe flag is set to false. --- proofs/proofview.ml | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) (limited to 'proofs') diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 4fc0c164e3..59a64658dc 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -1010,10 +1010,34 @@ end module Refine = struct + let extract_prefix env info = + let ctx1 = List.rev (Environ.named_context env) in + let ctx2 = List.rev (Evd.evar_context info) in + let rec share l1 l2 accu = match l1, l2 with + | d1 :: l1, d2 :: l2 -> + if d1 == d2 then share l1 l2 (d1 :: accu) + else (accu, d2 :: l2) + | _ -> (accu, l2) + in + share ctx1 ctx2 [] + let typecheck_evar ev env sigma = let info = Evd.find sigma ev in + (** Typecheck the hypotheses. *) + let type_hyp (sigma, env) (na, body, t as decl) = + let evdref = ref sigma in + let _ = Typing.sort_of env evdref t in + let () = match body with + | None -> () + | Some body -> Typing.check env evdref body t + in + (!evdref, Environ.push_named decl env) + in + let (common, changed) = extract_prefix env info in + let env = Environ.reset_with_named_context (Environ.val_of_named_context common) env in + let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in + (** Typecheck the conclusion *) let evdref = ref sigma in - let env = Environ.reset_with_named_context (Evd.evar_hyps info) env in let _ = Typing.sort_of env evdref (Evd.evar_concl info) in !evdref -- cgit v1.2.3 From af399d81b0505d1f0be8e73cf45044266d5749e5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 17 Nov 2015 12:39:35 +0100 Subject: Performance fix for destruct. The clenv_fchain function was needlessly merging universes coming from two evarmaps even though one was an extension of the other. A flag was added so that the tactic just retrieves the newer universes. --- proofs/clenv.ml | 4 ++-- proofs/clenv.mli | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'proofs') diff --git a/proofs/clenv.ml b/proofs/clenv.ml index a2cccc0e0b..5de8338ab6 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -379,12 +379,12 @@ let fchain_flags () = { (default_unify_flags ()) with allow_K_in_toplevel_higher_order_unification = true } -let clenv_fchain ?(flags=fchain_flags ()) mv clenv nextclenv = +let clenv_fchain ?with_univs ?(flags=fchain_flags ()) mv clenv nextclenv = (* Add the metavars of [nextclenv] to [clenv], with their name-environment *) let clenv' = { templval = clenv.templval; templtyp = clenv.templtyp; - evd = meta_merge nextclenv.evd clenv.evd; + evd = meta_merge ?with_univs nextclenv.evd clenv.evd; env = nextclenv.env } in (* unify the type of the template of [nextclenv] with the type of [mv] *) let clenv'' = diff --git a/proofs/clenv.mli b/proofs/clenv.mli index eb10817069..26e803354e 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -51,7 +51,7 @@ val refresh_undefined_univs : clausenv -> clausenv * Univ.universe_level_subst val connect_clenv : Goal.goal sigma -> clausenv -> clausenv val clenv_fchain : - ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv + ?with_univs:bool -> ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv (** {6 Unification with clenvs } *) -- cgit v1.2.3 From 5ccadc40d54090df5e6b61b4ecbb6083d01e5a88 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 18 Nov 2015 00:56:29 +0100 Subject: Inlining the only use of Clenv.connect_clenv. --- proofs/clenv.ml | 9 --------- proofs/clenv.mli | 1 - 2 files changed, 10 deletions(-) (limited to 'proofs') diff --git a/proofs/clenv.ml b/proofs/clenv.ml index ae790d9b82..bc6e75c38d 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -345,15 +345,6 @@ let clenv_pose_metas_as_evars clenv dep_mvs = (******************************************************************) -let connect_clenv gls clenv = - let evd = evars_reset_evd ~with_conv_pbs:true gls.sigma clenv.evd in - { clenv with - evd = evd ; - env = Goal.V82.env evd (sig_it gls) } - -(* let connect_clenv_key = Profile.declare_profile "connect_clenv";; *) -(* let connect_clenv = Profile.profile2 connect_clenv_key connect_clenv *) - (* [clenv_fchain mv clenv clenv'] * * Resolves the value of "mv" (which must be undefined) in clenv to be diff --git a/proofs/clenv.mli b/proofs/clenv.mli index eb10817069..ca62c985ec 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -49,7 +49,6 @@ val refresh_undefined_univs : clausenv -> clausenv * Univ.universe_level_subst (** {6 linking of clenvs } *) -val connect_clenv : Goal.goal sigma -> clausenv -> clausenv val clenv_fchain : ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv -- cgit v1.2.3 From 90fef3ffd236f2ed5575b0d11a47185185abc75b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 28 Nov 2015 19:41:17 +0100 Subject: Univs: correctly register universe binders for lemmas. --- proofs/pfedit.ml | 10 +++++++--- proofs/pfedit.mli | 7 ++++++- proofs/proof_global.ml | 28 +++++++++++++++++++--------- proofs/proof_global.mli | 17 ++++++++++------- 4 files changed, 42 insertions(+), 20 deletions(-) (limited to 'proofs') diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 02dbd1fdcb..cbccf00e72 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -20,14 +20,15 @@ let get_current_proof_name = Proof_global.get_current_proof_name let get_all_proof_names = Proof_global.get_all_proof_names type lemma_possible_guards = Proof_global.lemma_possible_guards +type universe_binders = Proof_global.universe_binders let delete_proof = Proof_global.discard let delete_current_proof = Proof_global.discard_current let delete_all_proofs = Proof_global.discard_all -let start_proof (id : Id.t) str sigma hyps c ?init_tac terminator = +let start_proof (id : Id.t) ?pl str sigma hyps c ?init_tac terminator = let goals = [ (Global.env_of_context hyps , c) ] in - Proof_global.start_proof sigma id str goals terminator; + Proof_global.start_proof sigma id ?pl str goals terminator; let env = Global.env () in ignore (Proof_global.with_current_proof (fun _ p -> match init_tac with @@ -54,6 +55,9 @@ let set_used_variables l = let get_used_variables () = Proof_global.get_used_variables () +let get_universe_binders () = + Proof_global.get_universe_binders () + exception NoSuchGoal let _ = Errors.register_handler begin function | NoSuchGoal -> Errors.error "No such goal." @@ -139,7 +143,7 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo let status = by tac in let _,(const,univs,_) = cook_proof () in delete_current_proof (); - const, status, univs + const, status, fst univs with reraise -> let reraise = Errors.push reraise in delete_current_proof (); diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index fc521ea432..d0528c9fdf 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -55,8 +55,10 @@ val delete_all_proofs : unit -> unit type lemma_possible_guards = Proof_global.lemma_possible_guards +type universe_binders = Id.t Loc.located list + val start_proof : - Id.t -> goal_kind -> Evd.evar_map -> named_context_val -> constr -> + Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> named_context_val -> constr -> ?init_tac:unit Proofview.tactic -> Proof_global.proof_terminator -> unit @@ -121,6 +123,9 @@ val set_used_variables : Id.t list -> Context.section_context * (Loc.t * Names.Id.t) list val get_used_variables : unit -> Context.section_context option +(** {6 Universe binders } *) +val get_universe_binders : unit -> universe_binders option + (** {6 ... } *) (** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th subgoal of the current focused proof or raises a [UserError] if no diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index c303f486c5..3d60ff217a 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -63,14 +63,14 @@ let _ = (* Extra info on proofs. *) type lemma_possible_guards = int list list -type proof_universes = Evd.evar_universe_context +type proof_universes = Evd.evar_universe_context * Universes.universe_binders option +type universe_binders = Id.t Loc.located list type proof_object = { id : Names.Id.t; entries : Safe_typing.private_constants Entries.definition_entry list; persistence : Decl_kinds.goal_kind; universes: proof_universes; - (* constraints : Univ.constraints; *) } type proof_ending = @@ -89,6 +89,7 @@ type pstate = { proof : Proof.proof; strength : Decl_kinds.goal_kind; mode : proof_mode Ephemeron.key; + universe_binders: universe_binders option; } (* The head of [!pstates] is the actual current proof, the other ones are @@ -226,7 +227,7 @@ let disactivate_proof_mode mode = end of the proof to close the proof. The proof is started in the evar map [sigma] (which can typically contain universe constraints). *) -let start_proof sigma id str goals terminator = +let start_proof sigma id ?pl str goals terminator = let initial_state = { pid = id; terminator = Ephemeron.create terminator; @@ -234,10 +235,11 @@ let start_proof sigma id str goals terminator = endline_tactic = None; section_vars = None; strength = str; - mode = find_proof_mode "No" } in + mode = find_proof_mode "No"; + universe_binders = pl } in push initial_state pstates -let start_dependent_proof id str goals terminator = +let start_dependent_proof id ?pl str goals terminator = let initial_state = { pid = id; terminator = Ephemeron.create terminator; @@ -245,10 +247,12 @@ let start_dependent_proof id str goals terminator = endline_tactic = None; section_vars = None; strength = str; - mode = find_proof_mode "No" } in + mode = find_proof_mode "No"; + universe_binders = pl } in push initial_state pstates let get_used_variables () = (cur_pstate ()).section_vars +let get_universe_binders () = (cur_pstate ()).universe_binders let proof_using_auto_clear = ref true let _ = Goptions.declare_bool_option @@ -296,7 +300,8 @@ let get_open_goals () = List.length shelf let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = - let { pid; section_vars; strength; proof; terminator } = cur_pstate () in + let { pid; section_vars; strength; proof; terminator; universe_binders } = + cur_pstate () in let poly = pi2 strength (* Polymorphic *) in let initial_goals = Proof.initial_goals proof in let initial_euctx = Proof.initial_euctx proof in @@ -362,8 +367,13 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = const_entry_opaque = true; const_entry_universes = univs; const_entry_polymorphic = poly}) - fpl initial_goals in - { id = pid; entries = entries; persistence = strength; universes = universes }, + fpl initial_goals in + let binders = + Option.map (fun names -> fst (Evd.universe_context ~names (Evd.from_ctx universes))) + universe_binders + in + { id = pid; entries = entries; persistence = strength; + universes = (universes, binders) }, fun pr_ending -> Ephemeron.get terminator pr_ending type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index a22545080b..ea7fc7cfa8 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -55,18 +55,18 @@ val compact_the_proof : unit -> unit (i.e. an proof ending command) and registers the appropriate values. *) type lemma_possible_guards = int list list -type proof_universes = Evd.evar_universe_context +type proof_universes = Evd.evar_universe_context * Universes.universe_binders option +type universe_binders = Names.Id.t Loc.located list type proof_object = { id : Names.Id.t; entries : Safe_typing.private_constants Entries.definition_entry list; persistence : Decl_kinds.goal_kind; universes: proof_universes; - (* constraints : Univ.constraints; *) - (** guards : lemma_possible_guards; *) } type proof_ending = - | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * proof_universes + | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * + proof_universes | Proved of Vernacexpr.opacity_flag * (Vernacexpr.lident * Decl_kinds.theorem_kind option) option * proof_object @@ -80,14 +80,15 @@ type closed_proof = proof_object * proof_terminator closing commands and the xml plugin); [terminator] is used at the end of the proof to close the proof. *) val start_proof : - Evd.evar_map -> Names.Id.t -> Decl_kinds.goal_kind -> (Environ.env * Term.types) list -> + Evd.evar_map -> Names.Id.t -> ?pl:universe_binders -> + Decl_kinds.goal_kind -> (Environ.env * Term.types) list -> proof_terminator -> unit (** Like [start_proof] except that there may be dependencies between initial goals. *) val start_dependent_proof : - Names.Id.t -> Decl_kinds.goal_kind -> Proofview.telescope -> - proof_terminator -> unit + Names.Id.t -> ?pl:universe_binders -> Decl_kinds.goal_kind -> + Proofview.telescope -> proof_terminator -> unit (** Update the proofs global environment after a side-effecting command (e.g. a sublemma definition) has been run inside it. Assumes @@ -140,6 +141,8 @@ val set_used_variables : Names.Id.t list -> Context.section_context * (Loc.t * Names.Id.t) list val get_used_variables : unit -> Context.section_context option +val get_universe_binders : unit -> universe_binders option + (**********************************************************) (* *) (* Proof modes *) -- cgit v1.2.3 From 6899d3aa567436784a08af4e179c2ef1fa504a02 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 21 Nov 2015 00:17:21 +0100 Subject: Moving extended_rel_vect/extended_rel_list to the kernel. It will later be used to fix a bug and improve some code. Interestingly, there were a redundant semantic equivalent to extended_rel_list in the kernel called local_rels, and another private copy of extended_rel_list in exactly the same file. --- proofs/logic.ml | 1 + 1 file changed, 1 insertion(+) (limited to 'proofs') diff --git a/proofs/logic.ml b/proofs/logic.ml index e80f5a64c7..1ba14e7d43 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -13,6 +13,7 @@ open Names open Nameops open Term open Vars +open Context open Termops open Environ open Reductionops -- cgit v1.2.3 From 5c5b5906426f38323fc5d63f4dc634672ebd2649 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 8 Dec 2015 23:34:38 +0100 Subject: Adding an unshelve tactical. This tactical is inspired by discussions on the Coq-club list. For now it is still undocumented, and there is room left for design issues. --- proofs/proofview.ml | 33 ++++++++++++++++++++++----------- proofs/proofview.mli | 4 ++++ proofs/proofview_monad.ml | 23 ++++++++++++++--------- proofs/proofview_monad.mli | 12 ++++++++---- 4 files changed, 48 insertions(+), 24 deletions(-) (limited to 'proofs') diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 59a64658dc..5981ad32da 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -32,7 +32,7 @@ type entry = (Term.constr * Term.types) list let proofview p = p.comb , p.solution -let compact el { comb; solution } = +let compact el ({ solution } as pv) = let nf = Evarutil.nf_evar solution in let size = Evd.fold (fun _ _ i -> i+1) solution 0 in let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in @@ -45,7 +45,7 @@ let compact el { comb; solution } = let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size)); - new_el, { comb; solution = new_solution } + new_el, { pv with solution = new_solution; } (** {6 Starting and querying a proof view} *) @@ -62,13 +62,13 @@ let dependent_init = let src = (Loc.ghost,Evar_kinds.GoalEvar) in (* Main routine *) let rec aux = function - | TNil sigma -> [], { solution = sigma; comb = []; } + | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] } | TCons (env, sigma, typ, t) -> let (sigma, econstr ) = Evarutil.new_evar env sigma ~src ~store typ in let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in let (gl, _) = Term.destEvar econstr in let entry = (econstr, typ) :: ret in - entry, { solution = sol; comb = gl :: comb; } + entry, { solution = sol; comb = gl :: comb; shelf = [] } in fun t -> let entry, v = aux t in @@ -232,6 +232,9 @@ let apply env t sp = match ans with | Nil (e, info) -> iraise (TacticFailure e, info) | Cons ((r, (state, _), status, info), _) -> + let (status, gaveup) = status in + let status = (status, state.shelf, gaveup) in + let state = { state with shelf = [] } in r, state, status, Trace.to_tree info @@ -578,7 +581,7 @@ let shelve = Comb.get >>= fun initial -> Comb.set [] >> InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >> - Shelf.put initial + Shelf.modify (fun gls -> gls @ initial) (** [contained_in_info e evi] checks whether the evar [e] appears in @@ -617,7 +620,7 @@ let shelve_unifiable = let (u,n) = partition_unifiable initial.solution initial.comb in Comb.set n >> InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >> - Shelf.put u + Shelf.modify (fun gls -> gls @ u) (** [guard_no_unifiable] fails with error [UnresolvedBindings] if some goals are unifiable (see {!shelve_unifiable}) in the current focus. *) @@ -639,6 +642,14 @@ let unshelve l p = let l = undefined p.solution l in { p with comb = p.comb@l } +let with_shelf tac = + let open Proof in + Shelf.get >>= fun shelf -> + Shelf.set [] >> + tac >>= fun ans -> + Shelf.get >>= fun gls -> + Shelf.set shelf >> + tclUNIT (gls, ans) (** [goodmod p m] computes the representative of [p] modulo [m] in the interval [[0,m-1]].*) @@ -867,7 +878,7 @@ module Unsafe = struct let tclSETGOALS = Comb.set let tclEVARSADVANCE evd = - Pv.modify (fun ps -> { solution = evd; comb = undefined evd ps.comb }) + Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb }) let tclEVARUNIVCONTEXT ctx = Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx }) @@ -1085,7 +1096,7 @@ struct let sigma = CList.fold_left Unsafe.mark_as_goal_evm sigma comb in let open Proof in InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"refine"++spc()++ Hook.get pr_constrv env sigma c)))) >> - Pv.set { solution = sigma; comb; } + Pv.modify (fun ps -> { ps with solution = sigma; comb; }) end (** Useful definitions *) @@ -1164,7 +1175,7 @@ module V82 = struct let sgs = CList.flatten goalss in let sgs = undefined evd sgs in InfoL.leaf (Info.Tactic (fun () -> Pp.str"")) >> - Pv.set { solution = evd; comb = sgs; } + Pv.set { ps with solution = evd; comb = sgs; } with e when catchable_exception e -> let (e, info) = Errors.push e in tclZERO ~info e @@ -1176,7 +1187,7 @@ module V82 = struct Pv.modify begin fun ps -> let map g s = GoalV82.nf_evar s g in let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in - { solution = evd; comb = goals; } + { ps with solution = evd; comb = goals; } end let has_unresolved_evar pv = @@ -1221,7 +1232,7 @@ module V82 = struct let of_tactic t gls = try - let init = { solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in + let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in let (_,final,_,_) = apply (GoalV82.env gls.Evd.sigma gls.Evd.it) t init in { Evd.sigma = final.solution ; it = final.comb } with Logic_monad.TacticFailure e as src -> diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 927df33a0c..659b783cb2 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -303,6 +303,10 @@ val guard_no_unifiable : unit tactic goals of p *) val unshelve : Goal.goal list -> proofview -> proofview +(** [with_shelf tac] executes [tac] and returns its result together with the set + of goals shelved by [tac]. The current shelf is unchanged. *) +val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic + (** If [n] is positive, [cycle n] puts the [n] first goal last. If [n] is negative, then it puts the [n] last goals first.*) val cycle : int -> unit tactic diff --git a/proofs/proofview_monad.ml b/proofs/proofview_monad.ml index 6e68cd2e45..a9faf0a833 100644 --- a/proofs/proofview_monad.ml +++ b/proofs/proofview_monad.ml @@ -157,8 +157,11 @@ end (** Type of proof views: current [evar_map] together with the list of focused goals. *) -type proofview = { solution : Evd.evar_map; comb : Goal.goal list } - +type proofview = { + solution : Evd.evar_map; + comb : Goal.goal list; + shelf : Goal.goal list; +} (** {6 Instantiation of the logic monad} *) @@ -171,10 +174,10 @@ module P = struct type e = bool (** Status (safe/unsafe) * shelved goals * given up *) - type w = bool * Evar.t list * Evar.t list + type w = bool * Evar.t list - let wunit = true , [] , [] - let wprod (b1,s1,g1) (b2,s2,g2) = b1 && b2 , s1@s2 , g1@g2 + let wunit = true , [] + let wprod (b1, g1) (b2, g2) = b1 && b2 , g1@g2 type u = Info.state @@ -226,19 +229,21 @@ module Env : State with type t := Environ.env = struct end module Status : Writer with type t := bool = struct - let put s = Logical.put (s,[],[]) + let put s = Logical.put (s, []) end -module Shelf : Writer with type t = Evar.t list = struct +module Shelf : State with type t = Evar.t list = struct (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *) type t = Evar.t list - let put sh = Logical.put (true,sh,[]) + let get = Logical.map (fun {shelf} -> shelf) Pv.get + let set c = Pv.modify (fun pv -> { pv with shelf = c }) + let modify f = Pv.modify (fun pv -> { pv with shelf = f pv.shelf }) end module Giveup : Writer with type t = Evar.t list = struct (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *) type t = Evar.t list - let put gs = Logical.put (true,[],gs) + let put gs = Logical.put (true, gs) end (** Lens and utilies pertaining to the info trace *) diff --git a/proofs/proofview_monad.mli b/proofs/proofview_monad.mli index d2a2e55fb1..a172259170 100644 --- a/proofs/proofview_monad.mli +++ b/proofs/proofview_monad.mli @@ -68,15 +68,19 @@ end (** Type of proof views: current [evar_map] together with the list of focused goals. *) -type proofview = { solution : Evd.evar_map; comb : Goal.goal list } +type proofview = { + solution : Evd.evar_map; + comb : Goal.goal list; + shelf : Goal.goal list; +} (** {6 Instantiation of the logic monad} *) module P : sig type s = proofview * Environ.env - (** Status (safe/unsafe) * shelved goals * given up *) - type w = bool * Evar.t list * Evar.t list + (** Status (safe/unsafe) * given up *) + type w = bool * Evar.t list val wunit : w val wprod : w -> w -> w @@ -123,7 +127,7 @@ module Status : Writer with type t := bool (** Lens to the list of goals which have been shelved during the execution of the tactic. *) -module Shelf : Writer with type t = Evar.t list +module Shelf : State with type t = Evar.t list (** Lens to the list of goals which were given up during the execution of the tactic. *) -- cgit v1.2.3 From 11eedd379d4b27e73a1999c0aacc2056311e8ba9 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 9 Dec 2015 12:01:32 +0100 Subject: The unshelve tactical now takes future goals into account. --- proofs/proofview.ml | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) (limited to 'proofs') diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 5981ad32da..452f27ff2b 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -644,12 +644,18 @@ let unshelve l p = let with_shelf tac = let open Proof in - Shelf.get >>= fun shelf -> - Shelf.set [] >> + Pv.get >>= fun pv -> + let { shelf; solution } = pv in + Pv.set { pv with shelf = []; solution = Evd.reset_future_goals solution } >> tac >>= fun ans -> - Shelf.get >>= fun gls -> - Shelf.set shelf >> - tclUNIT (gls, ans) + Pv.get >>= fun npv -> + let { shelf = gls; solution = sigma } = npv in + let gls' = Evd.future_goals sigma in + let fgoals = Evd.future_goals solution in + let pgoal = Evd.principal_future_goal solution in + let sigma = Evd.restore_future_goals sigma fgoals pgoal in + Pv.set { npv with shelf; solution = sigma } >> + tclUNIT (CList.rev_append gls' gls, ans) (** [goodmod p m] computes the representative of [p] modulo [m] in the interval [[0,m-1]].*) -- cgit v1.2.3 From 3c81c6c3b595ef06e0c01e51775aa0118f44e421 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 11 Dec 2015 17:59:42 +0100 Subject: Univs: Fix bug #4363, nested abstract. --- proofs/proof_global.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'proofs') diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 3d60ff217a..3edd34e5f6 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -333,7 +333,8 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = (* For vi2vo compilation proofs are computed now but we need to * complement the univ constraints of the typ with the ones of * the body. So we keep the two sets distinct. *) - let ctx_body = restrict_universe_context ctx used_univs_body in + let used_univs = Univ.LSet.union used_univs_body used_univs_typ in + let ctx_body = restrict_universe_context ctx used_univs in (initunivs, typ), ((body, ctx_body), eff) else let initunivs = Univ.UContext.empty in -- cgit v1.2.3 From 33742251e62a49c7996b96ca7077cf985627d14b Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 15 Dec 2015 23:15:02 +0100 Subject: Proof using: do not clear unused section hyps automatically The option is still there, but not documented since it is too dangerous. Hints and type classes instances are not taking cleared variables into account. --- proofs/proof_global.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'proofs') diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 3edd34e5f6..c32e02344d 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -254,7 +254,7 @@ let start_dependent_proof id ?pl str goals terminator = let get_used_variables () = (cur_pstate ()).section_vars let get_universe_binders () = (cur_pstate ()).universe_binders -let proof_using_auto_clear = ref true +let proof_using_auto_clear = ref false let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = false; -- cgit v1.2.3 From 3049b2930ec2bd4adf886fc90bf01a478b318477 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 2 Jan 2016 17:01:28 +0100 Subject: Remove some useless module opening. --- proofs/proof_global.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'proofs') diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 5cfec1b0db..8808dbbacd 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -496,10 +496,10 @@ module Bullet = struct | NoBulletInUse -> None | ProofFinished -> None | Suggest b -> Some ("Focus next goal with bullet " - ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) + ^ Pp.string_of_ppcmds (pr_bullet b) ^".") | Unfinished b -> Some ("The current bullet " - ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) + ^ Pp.string_of_ppcmds (pr_bullet b) ^ " is unfinished.") (* give always a message. *) @@ -508,9 +508,9 @@ module Bullet = struct | NeedClosingBrace -> "Try unfocusing with \"}\"." | NoBulletInUse -> assert false (* This should never raise an error. *) | ProofFinished -> "No more subgoals." - | Suggest b -> ("Bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) + | Suggest b -> ("Bullet " ^ Pp.string_of_ppcmds (pr_bullet b) ^ " is mandatory here.") - | Unfinished b -> ("Current bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) + | Unfinished b -> ("Current bullet " ^ Pp.string_of_ppcmds (pr_bullet b) ^ " is not finished.") exception FailedBullet of t * suggestion @@ -519,7 +519,7 @@ module Bullet = struct Errors.register_handler (function | FailedBullet (b,sugg) -> - let prefix = "Wrong bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) ^ " : " in + let prefix = "Wrong bullet " ^ Pp.string_of_ppcmds (pr_bullet b) ^ " : " in Errors.errorlabstrm "Focus" (str prefix ++ str (suggest_on_error sugg)) | _ -> raise Errors.Unhandled) -- cgit v1.2.3 From 80bbdf335be5657f5ab33b4aa02e21420d341de2 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 2 Jan 2016 17:11:03 +0100 Subject: Remove some unused functions. Note: they do not even seem to have a debugging purpose, so better remove them before they bitrot. --- proofs/redexpr.ml | 2 -- 1 file changed, 2 deletions(-) (limited to 'proofs') diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index be92f2b04c..89ecdb0df2 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -158,8 +158,6 @@ let make_flag env f = f.rConst red in red -let is_reference = function PRef _ | PVar _ -> true | _ -> false - (* table of custom reductino fonctions, not synchronized, filled via ML calls to [declare_reduction] *) let reduction_tab = ref String.Map.empty -- cgit v1.2.3 From 5d26829704b2602ede45183cba54ab219e453c0e Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 2 Jan 2016 17:57:06 +0100 Subject: Use streams rather than strings to handle bullet suggestions. --- proofs/proof_global.ml | 32 +++++++++++++------------------- proofs/proof_global.mli | 4 ++-- proofs/proofview.ml | 7 +++---- proofs/proofview.mli | 2 +- 4 files changed, 19 insertions(+), 26 deletions(-) (limited to 'proofs') diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 8808dbbacd..22aab6585c 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -466,7 +466,7 @@ module Bullet = struct type behavior = { name : string; put : Proof.proof -> t -> Proof.proof; - suggest: Proof.proof -> string option + suggest: Proof.proof -> std_ppcmds } let behaviors = Hashtbl.create 4 @@ -476,7 +476,7 @@ module Bullet = struct let none = { name = "None"; put = (fun x _ -> x); - suggest = (fun _ -> None) + suggest = (fun _ -> mt ()) } let _ = register_behavior none @@ -492,26 +492,20 @@ module Bullet = struct (* give a message only if more informative than the standard coq message *) let suggest_on_solved_goal sugg = match sugg with - | NeedClosingBrace -> Some "Try unfocusing with \"}\"." - | NoBulletInUse -> None - | ProofFinished -> None - | Suggest b -> Some ("Focus next goal with bullet " - ^ Pp.string_of_ppcmds (pr_bullet b) - ^".") - | Unfinished b -> Some ("The current bullet " - ^ Pp.string_of_ppcmds (pr_bullet b) - ^ " is unfinished.") + | NeedClosingBrace -> str"Try unfocusing with \"}\"." + | NoBulletInUse -> mt () + | ProofFinished -> mt () + | Suggest b -> str"Focus next goal with bullet " ++ pr_bullet b ++ str"." + | Unfinished b -> str"The current bullet " ++ pr_bullet b ++ str" is unfinished." (* give always a message. *) let suggest_on_error sugg = match sugg with - | NeedClosingBrace -> "Try unfocusing with \"}\"." + | NeedClosingBrace -> str"Try unfocusing with \"}\"." | NoBulletInUse -> assert false (* This should never raise an error. *) - | ProofFinished -> "No more subgoals." - | Suggest b -> ("Bullet " ^ Pp.string_of_ppcmds (pr_bullet b) - ^ " is mandatory here.") - | Unfinished b -> ("Current bullet " ^ Pp.string_of_ppcmds (pr_bullet b) - ^ " is not finished.") + | ProofFinished -> str"No more subgoals." + | Suggest b -> str"Bullet " ++ pr_bullet b ++ str" is mandatory here." + | Unfinished b -> str"Current bullet " ++ pr_bullet b ++ str" is not finished." exception FailedBullet of t * suggestion @@ -519,8 +513,8 @@ module Bullet = struct Errors.register_handler (function | FailedBullet (b,sugg) -> - let prefix = "Wrong bullet " ^ Pp.string_of_ppcmds (pr_bullet b) ^ " : " in - Errors.errorlabstrm "Focus" (str prefix ++ str (suggest_on_error sugg)) + let prefix = str"Wrong bullet " ++ pr_bullet b ++ str" : " in + Errors.errorlabstrm "Focus" (prefix ++ suggest_on_error sugg) | _ -> raise Errors.Unhandled) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 5f11589508..5d89044c3d 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -172,7 +172,7 @@ module Bullet : sig type behavior = { name : string; put : Proof.proof -> t -> Proof.proof; - suggest: Proof.proof -> string option + suggest: Proof.proof -> Pp.std_ppcmds } (** A registered behavior can then be accessed in Coq @@ -189,7 +189,7 @@ module Bullet : sig (** Handles focusing/defocusing with bullets: *) val put : Proof.proof -> t -> Proof.proof - val suggest : Proof.proof -> string option + val suggest : Proof.proof -> Pp.std_ppcmds end diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 9ee7df14c8..e01bed5dad 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -353,7 +353,7 @@ exception NoSuchGoals of int (* This hook returns a string to be appended to the usual message. Primarily used to add a suggestion about the right bullet to use to focus the next goal, if applicable. *) -let nosuchgoals_hook:(int -> string option) ref = ref ((fun n -> None)) +let nosuchgoals_hook:(int -> std_ppcmds) ref = ref (fun n -> mt ()) let set_nosuchgoals_hook f = nosuchgoals_hook := f @@ -361,10 +361,9 @@ let set_nosuchgoals_hook f = nosuchgoals_hook := f (* This uses the hook above *) let _ = Errors.register_handler begin function | NoSuchGoals n -> - let suffix:string option = (!nosuchgoals_hook) n in + let suffix = !nosuchgoals_hook n in Errors.errorlabstrm "" - (str "No such " ++ str (String.plural n "goal") ++ str "." - ++ pr_opt str suffix) + (str "No such " ++ str (String.plural n "goal") ++ str "." ++ suffix) | _ -> raise Errors.Unhandled end diff --git a/proofs/proofview.mli b/proofs/proofview.mli index a92abcbbf1..96fe474f66 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -235,7 +235,7 @@ val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic This hook is used to add a suggestion about bullets when applicable. *) exception NoSuchGoals of int -val set_nosuchgoals_hook: (int -> string option) -> unit +val set_nosuchgoals_hook: (int -> Pp.std_ppcmds) -> unit val tclFOCUS : int -> int -> 'a tactic -> 'a tactic -- cgit v1.2.3 From 9d991d36c07efbb6428e277573bd43f6d56788fc Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 8 Jan 2016 10:00:21 +0100 Subject: CLEANUP: kernel/context.ml{,i} The structure of the Context module was refined in such a way that: - Types and functions related to rel-context declarations were put into the Context.Rel.Declaration module. - Types and functions related to rel-context were put into the Context.Rel module. - Types and functions related to named-context declarations were put into the Context.Named.Declaration module. - Types and functions related to named-context were put into the Context.Named module. - Types and functions related to named-list-context declarations were put into Context.NamedList.Declaration module. - Types and functions related to named-list-context were put into Context.NamedList module. Some missing comments were added to the *.mli file. The output of ocamldoc was checked whether it looks in a reasonable way. "TODO: cleanup" was removed The order in which are exported functions listed in the *.mli file was changed. (as in a mature modules, this order usually is not random) The order of exported functions in Context.{Rel,Named} modules is now consistent. (as there is no special reason why that order should be different) The order in which are functions defined in the *.ml file is the same as the order in which they are listed in the *.mli file. (as there is no special reason to define them in a different order) The name of the original fold_{rel,named}_context{,_reverse} functions was changed to better indicate what those functions do. (Now they are called Context.{Rel,Named}.fold_{inside,outside}) The original comments originally attached to the fold_{rel,named}_context{,_reverse} did not full make sense so they were updated. Thrown exceptions are now documented. Naming of formal parameters was made more consistent across different functions. Comments of similar functions in different modules are now consistent. Comments from *.mli files were copied to *.ml file. (We need that information in *.mli files because that is were ocamldoc needs it. It is nice to have it also in *.ml files because when we are using Merlin and jump to the definion of the function, we can see the comments also there and do not need to open a different file if we want to see it.) When we invoke ocamldoc, we instruct it to generate UTF-8 HTML instead of (default) ISO-8859-1. (UTF-8 characters are used in our ocamldoc markup) "open Context" was removed from all *.mli and *.ml files. (Originally, it was OK to do that. Now it is not.) An entry to dev/doc/changes.txt file was added that describes how the names of types and functions have changed. --- proofs/goal.mli | 2 +- proofs/logic.ml | 1 - proofs/logic.mli | 2 +- proofs/pfedit.ml | 2 +- proofs/proofview.mli | 2 +- proofs/refiner.ml | 4 ++-- proofs/refiner.mli | 3 +-- proofs/tacmach.ml | 4 ++-- proofs/tacmach.mli | 11 +++++------ 9 files changed, 14 insertions(+), 17 deletions(-) (limited to 'proofs') diff --git a/proofs/goal.mli b/proofs/goal.mli index a00a95a2ff..46318b789f 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -67,7 +67,7 @@ module V82 : sig val same_goal : Evd.evar_map -> goal -> Evd.evar_map -> goal -> bool (* Used for congruence closure *) - val new_goal_with : Evd.evar_map -> goal -> Context.named_context -> goal Evd.sigma + val new_goal_with : Evd.evar_map -> goal -> Context.Named.t -> goal Evd.sigma (* Used by the compatibility layer and typeclasses *) val nf_evar : Evd.evar_map -> goal -> goal * Evd.evar_map diff --git a/proofs/logic.ml b/proofs/logic.ml index 1ba14e7d43..e80f5a64c7 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -13,7 +13,6 @@ open Names open Nameops open Term open Vars -open Context open Termops open Environ open Reductionops diff --git a/proofs/logic.mli b/proofs/logic.mli index d034b73c56..d33f56bb7c 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -53,4 +53,4 @@ exception RefinerError of refiner_error val catchable_exception : exn -> bool val convert_hyp : bool -> Environ.named_context_val -> evar_map -> - Context.named_declaration -> Environ.named_context_val + Context.Named.Declaration.t -> Environ.named_context_val diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 9f2a00135b..155b2cfca4 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -215,7 +215,7 @@ let solve_by_implicit_tactic env sigma evk = match (!implicit_tactic, snd (evar_source evk sigma)) with | Some tac, (Evar_kinds.ImplicitArg _ | Evar_kinds.QuestionMark _) when - Context.named_context_equal (Environ.named_context_of_val evi.evar_hyps) + Context.Named.equal (Environ.named_context_of_val evi.evar_hyps) (Environ.named_context env) -> let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (Errors.UserError ("",Pp.str"Proof is not complete."))) []) in (try diff --git a/proofs/proofview.mli b/proofs/proofview.mli index a92abcbbf1..aac56e565e 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -446,7 +446,7 @@ module Goal : sig environment of [gl] (i.e. the global environment and the hypotheses) and the current evar map. *) val concl : ([ `NF ], 'r) t -> Term.constr - val hyps : ([ `NF ], 'r) t -> Context.named_context + val hyps : ([ `NF ], 'r) t -> Context.Named.t val env : ('a, 'r) t -> Environ.env val sigma : ('a, 'r) t -> 'r Sigma.t val extra : ('a, 'r) t -> Evd.Store.t diff --git a/proofs/refiner.ml b/proofs/refiner.ml index ba62b2cb2d..de70250626 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -197,10 +197,10 @@ let tclNOTSAMEGOAL (tac : tactic) goal = destruct), this is not detected by this tactical. *) let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) :Proof_type.goal list Evd.sigma = - let oldhyps:Context.named_context = pf_hyps goal in + let oldhyps:Context.Named.t = pf_hyps goal in let rslt:Proof_type.goal list Evd.sigma = tac goal in let { it = gls; sigma = sigma; } = rslt in - let hyps:Context.named_context list = + let hyps:Context.Named.t list = List.map (fun gl -> pf_hyps { it = gl; sigma=sigma; }) gls in let cmp (i1, c1, t1) (i2, c2, t2) = Names.Id.equal i1 i2 in let newhyps = diff --git a/proofs/refiner.mli b/proofs/refiner.mli index a81555ff5e..2959787d4c 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Context open Evd open Proof_type @@ -16,7 +15,7 @@ val sig_it : 'a sigma -> 'a val project : 'a sigma -> evar_map val pf_env : goal sigma -> Environ.env -val pf_hyps : goal sigma -> named_context +val pf_hyps : goal sigma -> Context.Named.t val unpackage : 'a sigma -> evar_map ref * 'a val repackage : evar_map ref -> 'a -> 'a sigma diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 57c60cbeed..dc0cf81a76 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -48,7 +48,7 @@ let pf_last_hyp gl = List.hd (pf_hyps gl) let pf_get_hyp gls id = try - Context.lookup_named id (pf_hyps gls) + Context.Named.lookup id (pf_hyps gls) with Not_found -> raise (RefinerError (NoSuchHyp id)) @@ -198,7 +198,7 @@ module New = struct let pf_get_hyp id gl = let hyps = Proofview.Goal.hyps gl in let sign = - try Context.lookup_named id hyps + try Context.Named.lookup id hyps with Not_found -> raise (RefinerError (NoSuchHyp id)) in sign diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index c45fd250cb..b7915e8371 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -8,7 +8,6 @@ open Names open Term -open Context open Environ open Evd open Proof_type @@ -34,18 +33,18 @@ val apply_sig_tac : val pf_concl : goal sigma -> types val pf_env : goal sigma -> env -val pf_hyps : goal sigma -> named_context +val pf_hyps : goal sigma -> Context.Named.t (*i val pf_untyped_hyps : goal sigma -> (Id.t * constr) list i*) val pf_hyps_types : goal sigma -> (Id.t * types) list val pf_nth_hyp_id : goal sigma -> int -> Id.t -val pf_last_hyp : goal sigma -> named_declaration +val pf_last_hyp : goal sigma -> Context.Named.Declaration.t val pf_ids_of_hyps : goal sigma -> Id.t list val pf_global : goal sigma -> Id.t -> constr val pf_unsafe_type_of : goal sigma -> constr -> types val pf_type_of : goal sigma -> constr -> evar_map * types val pf_hnf_type_of : goal sigma -> constr -> types -val pf_get_hyp : goal sigma -> Id.t -> named_declaration +val pf_get_hyp : goal sigma -> Id.t -> Context.Named.Declaration.t val pf_get_hyp_typ : goal sigma -> Id.t -> types val pf_get_new_id : Id.t -> goal sigma -> Id.t @@ -123,9 +122,9 @@ module New : sig val pf_ids_of_hyps : ('a, 'r) Proofview.Goal.t -> identifier list val pf_hyps_types : ('a, 'r) Proofview.Goal.t -> (identifier * types) list - val pf_get_hyp : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> named_declaration + val pf_get_hyp : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> Context.Named.Declaration.t val pf_get_hyp_typ : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> types - val pf_last_hyp : ([ `NF ], 'r) Proofview.Goal.t -> named_declaration + val pf_last_hyp : ([ `NF ], 'r) Proofview.Goal.t -> Context.Named.Declaration.t val pf_nf_concl : ([ `LZ ], 'r) Proofview.Goal.t -> types val pf_reduce_to_quantified_ind : ('a, 'r) Proofview.Goal.t -> types -> pinductive * types -- cgit v1.2.3 From 13ef3c9a4161db85f10c9c5305e44b8ca66f2eaf Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 19 Jan 2016 16:52:04 +0100 Subject: Fixing Not_found on unknown bullet behavior. --- proofs/proof_global.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'proofs') diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index c32e02344d..46f0db5fe1 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -623,7 +623,10 @@ module Bullet = struct (!current_behavior).name end; optwrite = begin fun n -> - current_behavior := Hashtbl.find behaviors n + current_behavior := + try Hashtbl.find behaviors n + with Not_found -> + Errors.error ("Unknown bullet behavior: \"" ^ n ^ "\".") end } -- cgit v1.2.3 From 86f5c0cbfa64c5d0949365369529c5b607878ef8 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 20 Jan 2016 17:25:10 +0100 Subject: Update copyright headers. --- proofs/clenv.ml | 2 +- proofs/clenv.mli | 2 +- proofs/clenvtac.ml | 2 +- proofs/clenvtac.mli | 2 +- proofs/evar_refiner.ml | 2 +- proofs/evar_refiner.mli | 2 +- proofs/goal.ml | 2 +- proofs/goal.mli | 2 +- proofs/logic.ml | 2 +- proofs/logic.mli | 2 +- proofs/logic_monad.ml | 2 +- proofs/logic_monad.mli | 2 +- proofs/pfedit.ml | 2 +- proofs/pfedit.mli | 2 +- proofs/proof.ml | 2 +- proofs/proof.mli | 2 +- proofs/proof_global.ml | 2 +- proofs/proof_global.mli | 2 +- proofs/proof_type.ml | 2 +- proofs/proof_type.mli | 2 +- proofs/proof_using.ml | 2 +- proofs/proof_using.mli | 2 +- proofs/proofview.ml | 2 +- proofs/proofview.mli | 2 +- proofs/proofview_monad.ml | 2 +- proofs/proofview_monad.mli | 2 +- proofs/redexpr.ml | 2 +- proofs/redexpr.mli | 2 +- proofs/refiner.ml | 2 +- proofs/refiner.mli | 2 +- proofs/tacmach.ml | 2 +- proofs/tacmach.mli | 2 +- proofs/tactic_debug.ml | 2 +- proofs/tactic_debug.mli | 2 +- 34 files changed, 34 insertions(+), 34 deletions(-) (limited to 'proofs') diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 5de8338ab6..88e1bce95a 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* match (prod_assum (snd (decompose_prod_n_assum n c))) with | [_,None,c] -> isRel c && Int.equal (destRel c) (n - i) | _ -> false) 0 lc Suppose that you do not know about rel-context and named-context. (that is the case of people who just started to read the source code) Merlin would tell you that the type of the value you are destructing by "match" is: 'a * 'b option * Constr.t (* worst-case scenario *) or Named.Name.t * Constr.t option * Constr.t (* best-case scenario (?) *) To me, this is akin to wearing an opaque veil. It is hard to figure out the meaning of the values you are looking at. In particular, it is hard to discover the connection between the value we are destructing above and the datatypes and functions defined in the "kernel/context.ml" file. In this case, the connection is there, but it is not visible (between the function above and the "Context" module). ------------------------------------------------------------------------ Now consider, what happens when the reader see the same function presented in the following form: let test_strict_disjunction n lc = Array.for_all_i (fun i c -> match (prod_assum (snd (decompose_prod_n_assum n c))) with | [LocalAssum (_,c)] -> isRel c && Int.equal (destRel c) (n - i) | _ -> false) 0 lc If the reader haven't seen "LocalAssum" before, (s)he can use Merlin to jump to the corresponding definition and learn more. In this case, the connection is there, and it is directly visible (between the function above and the "Context" module). (2) Also, if we already have the concepts such as: - local declaration - local assumption - local definition and we describe these notions meticulously in the Reference Manual, then it is a real pity not to reinforce the connection of the actual code with the abstract description we published. --- proofs/goal.ml | 5 +++-- proofs/logic.ml | 51 +++++++++++++++++++++++++++++--------------------- proofs/proof_global.ml | 7 ++++--- proofs/proof_using.ml | 8 +++++--- proofs/proofview.ml | 22 +++++++++++++++------- proofs/refiner.ml | 6 +++--- proofs/tacmach.ml | 17 ++++++++++------- 7 files changed, 70 insertions(+), 46 deletions(-) (limited to 'proofs') diff --git a/proofs/goal.ml b/proofs/goal.ml index 1dd5be0e71..84ffee23c1 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -9,6 +9,7 @@ open Util open Pp open Term +open Context.Named.Declaration (* This module implements the abstract interface to goals *) (* A general invariant of the module, is that a goal whose associated @@ -73,7 +74,7 @@ module V82 = struct let (evars, evk) = Evarutil.new_pure_evar_full evars evi in let evars = Evd.restore_future_goals evars prev_future_goals prev_principal_goal in let ctxt = Environ.named_context_of_val hyps in - let inst = Array.map_of_list (fun (id, _, _) -> mkVar id) ctxt in + let inst = Array.map_of_list (mkVar % get_id) ctxt in let ev = Term.mkEvar (evk,inst) in (evk, ev, evars) @@ -139,7 +140,7 @@ module V82 = struct 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 + try ignore (Environ.lookup_named (get_id decl) genv); false with Not_found -> true in Environ.fold_named_context_reverse (fun t decl -> if is_proof_var decl then diff --git a/proofs/logic.ml b/proofs/logic.ml index 99e32db046..09f308abef 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -22,6 +22,7 @@ open Proof_type open Type_errors open Retyping open Misctypes +open Context.Named.Declaration type refiner_error = @@ -160,7 +161,8 @@ let reorder_context env sign ord = | _ -> (match ctxt_head with | [] -> error_no_such_hypothesis (List.hd ord) - | (x,_,_ as d) :: ctxt -> + | d :: ctxt -> + let x = get_id d in if Id.Set.mem x expected then step ord (Id.Set.remove x expected) ctxt (push_item x d moved_hyps) ctxt_tail @@ -175,7 +177,8 @@ let reorder_val_context env sign ord = -let check_decl_position env sign (x,_,_ as d) = +let check_decl_position env sign d = + let x = get_id d in let needed = global_vars_set_of_decl env d in let deps = dependency_closure env (named_context_of_val sign) needed in if Id.List.mem x deps then @@ -200,16 +203,17 @@ let move_location_eq m1 m2 = match m1, m2 with let rec get_hyp_after h = function | [] -> error_no_such_hypothesis h - | (hyp,_,_) :: right -> - if Id.equal hyp h then - match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveFirst + | d :: right -> + if Id.equal (get_id d) h then + match right with d' ::_ -> MoveBefore (get_id d') | [] -> MoveFirst else get_hyp_after h right let split_sign hfrom hto l = let rec splitrec left toleft = function | [] -> error_no_such_hypothesis hfrom - | (hyp,c,typ) as d :: right -> + | d :: right -> + let hyp,_,typ = to_tuple d in if Id.equal hyp hfrom then (left,right,d, toleft || move_location_eq hto MoveLast) else @@ -227,27 +231,28 @@ let hyp_of_move_location = function | MoveBefore id -> id | _ -> assert false -let move_hyp toleft (left,(idfrom,_,_ as declfrom),right) hto = +let move_hyp toleft (left,declfrom,right) hto = let env = Global.env() in - let test_dep (hyp,c,typ as d) (hyp2,c,typ2 as d2) = + let test_dep d d2 = if toleft - then occur_var_in_decl env hyp2 d - else occur_var_in_decl env hyp d2 + then occur_var_in_decl env (get_id d2) d + else occur_var_in_decl env (get_id d) d2 in let rec moverec first middle = function | [] -> if match hto with MoveFirst | MoveLast -> false | _ -> true then error_no_such_hypothesis (hyp_of_move_location hto); List.rev first @ List.rev middle - | (hyp,_,_) :: _ as right when move_location_eq hto (MoveBefore hyp) -> + | d :: _ as right when move_location_eq hto (MoveBefore (get_id d)) -> List.rev first @ List.rev middle @ right - | (hyp,_,_) as d :: right -> + | d :: right -> + let hyp = get_id d in let (first',middle') = if List.exists (test_dep d) middle then if not (move_location_eq hto (MoveAfter hyp)) then (first, d::middle) else - errorlabstrm "move_hyp" (str "Cannot move " ++ pr_id idfrom ++ + errorlabstrm "move_hyp" (str "Cannot move " ++ pr_id (get_id declfrom) ++ Miscprint.pr_move_location pr_id hto ++ str (if toleft then ": it occurs in " else ": it depends on ") ++ pr_id hyp ++ str ".") @@ -483,12 +488,14 @@ and mk_casegoals sigma goal goalacc p c = (acc'',lbrty,conclty,sigma,p',c') -let convert_hyp check sign sigma (id,b,bt as d) = +let convert_hyp check sign sigma d = + let id,b,bt = to_tuple d in let env = Global.env() in let reorder = ref [] in let sign' = apply_to_hyp sign id - (fun _ (_,c,ct) _ -> + (fun _ d' _ -> + let _,c,ct = to_tuple d' in let env = Global.env_of_context sign in if check && not (is_conv env sigma bt ct) then errorlabstrm "Logic.convert_hyp" @@ -522,14 +529,14 @@ let prim_refiner r sigma goal = if replace then let nexthyp = get_hyp_after id (named_context_of_val sign) in let sign,t,cl,sigma = clear_hyps2 env sigma (Id.Set.singleton id) sign t cl in - move_hyp false ([],(id,None,t),named_context_of_val sign) + move_hyp false ([], LocalAssum (id,t),named_context_of_val sign) nexthyp, t,cl,sigma else (if !check && mem_named_context id (named_context_of_val sign) then errorlabstrm "Logic.prim_refiner" (str "Variable " ++ pr_id id ++ str " is already declared."); - push_named_context_val (id,None,t) sign,t,cl,sigma) in + push_named_context_val (LocalAssum (id,t)) sign,t,cl,sigma) in let (sg2,ev2,sigma) = Goal.V82.mk_goal sigma sign cl (Goal.V82.extra sigma goal) in let oterm = Term.mkNamedLetIn id ev1 t ev2 in @@ -546,7 +553,8 @@ let prim_refiner r sigma goal = with Not_found -> error "Cannot do a fixpoint on a non inductive type." else - check_ind (push_rel (na,None,c1) env) (k-1) b + let open Context.Rel.Declaration in + check_ind (push_rel (LocalAssum (na,c1)) env) (k-1) b | _ -> error "Not enough products." in let ((sp,_),u) = check_ind env n cl in @@ -560,7 +568,7 @@ let prim_refiner r sigma goal = if !check && mem_named_context f (named_context_of_val sign) then errorlabstrm "Logic.prim_refiner" (str "Name " ++ pr_id f ++ str " already used in the environment"); - mk_sign (push_named_context_val (f,None,ar) sign) oth + mk_sign (push_named_context_val (LocalAssum (f,ar)) sign) oth | [] -> Evd.Monad.List.map (fun (_,_,c) sigma -> let gl,ev,sig' = @@ -584,7 +592,8 @@ let prim_refiner r sigma goal = let rec check_is_coind env cl = let b = whd_betadeltaiota env sigma cl in match kind_of_term b with - | Prod (na,c1,b) -> check_is_coind (push_rel (na,None,c1) env) b + | Prod (na,c1,b) -> let open Context.Rel.Declaration in + check_is_coind (push_rel (LocalAssum (na,c1)) env) b | _ -> try let _ = find_coinductive env sigma b in () @@ -601,7 +610,7 @@ let prim_refiner r sigma goal = error "Name already used in the environment.") with | Not_found -> - mk_sign (push_named_context_val (f,None,ar) sign) oth) + mk_sign (push_named_context_val (LocalAssum (f,ar)) sign) oth) | [] -> Evd.Monad.List.map (fun (_,c) sigma -> let gl,ev,sigma = diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index fc33e9a657..403a36141f 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -267,18 +267,19 @@ let _ = Goptions.declare_bool_option Goptions.optwrite = (fun b -> proof_using_auto_clear := b) } let set_used_variables l = + let open Context.Named.Declaration in let env = Global.env () in let ids = List.fold_right Id.Set.add l Id.Set.empty in let ctx = Environ.keep_hyps env ids in let ctx_set = - List.fold_right Id.Set.add (List.map pi1 ctx) Id.Set.empty in + List.fold_right Id.Set.add (List.map get_id ctx) Id.Set.empty in let vars_of = Environ.global_vars_set in let aux env entry (ctx, all_safe, to_clear as orig) = match entry with - | (x,None,_) -> + | LocalAssum (x,_) -> if Id.Set.mem x all_safe then orig else (ctx, all_safe, (Loc.ghost,x)::to_clear) - | (x,Some bo, ty) as decl -> + | LocalDef (x,bo, ty) as decl -> if Id.Set.mem x all_safe then orig else let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in if Id.Set.subset vars all_safe diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml index a69645b116..681a7fa1ad 100644 --- a/proofs/proof_using.ml +++ b/proofs/proof_using.ml @@ -10,6 +10,7 @@ open Names open Environ open Util open Vernacexpr +open Context.Named.Declaration let to_string e = let rec aux = function @@ -33,7 +34,8 @@ let in_nameset = let rec close_fwd e s = let s' = - List.fold_left (fun s (id,b,ty) -> + List.fold_left (fun s decl -> + let (id,b,ty) = Context.Named.Declaration.to_tuple decl in let vb = Option.(default Id.Set.empty (map (global_vars_set e) b)) in let vty = global_vars_set e ty in let vbty = Id.Set.union vb vty in @@ -61,13 +63,13 @@ and set_of_id env ty id = Id.Set.union (global_vars_set env ty) acc) Id.Set.empty ty else if Id.to_string id = "All" then - List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty + List.fold_right Id.Set.add (List.map get_id (named_context env)) Id.Set.empty else if CList.mem_assoc_f Id.equal id !known_names then process_expr env (CList.assoc_f Id.equal id !known_names) [] else Id.Set.singleton id and full_set env = - List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty + List.fold_right Id.Set.add (List.map get_id (named_context env)) Id.Set.empty let process_expr env e ty = let ty_expr = SsSingl(Loc.ghost, Id.of_string "Type") in diff --git a/proofs/proofview.ml b/proofs/proofview.ml index ff8effcda4..ebce25d293 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -17,6 +17,7 @@ open Pp open Util open Proofview_monad open Sigma.Notations +open Context.Named.Declaration (** Main state of tactics *) type proofview = Proofview_monad.proofview @@ -750,9 +751,15 @@ module Progress = struct let eq_named_context_val sigma1 sigma2 ctx1 ctx2 = let open Environ in let c1 = named_context_of_val ctx1 and c2 = named_context_of_val ctx2 in - let eq_named_declaration (i1, c1, t1) (i2, c2, t2) = - Names.Id.equal i1 i2 && Option.equal (eq_constr sigma1 sigma2) c1 c2 - && (eq_constr sigma1 sigma2) t1 t2 + let eq_named_declaration d1 d2 = + match d1, d2 with + | LocalAssum (i1,t1), LocalAssum (i2,t2) -> + Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 t1 t2 + | LocalDef (i1,c1,t1), LocalDef (i2,c2,t2) -> + Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 c1 c2 + && eq_constr sigma1 sigma2 t1 t2 + | _ -> + false in List.equal eq_named_declaration c1 c2 let eq_evar_body sigma1 sigma2 b1 b2 = @@ -1075,12 +1082,13 @@ struct let typecheck_evar ev env sigma = let info = Evd.find sigma ev in (** Typecheck the hypotheses. *) - let type_hyp (sigma, env) (na, body, t as decl) = + let type_hyp (sigma, env) decl = + let t = get_type decl in let evdref = ref sigma in let _ = Typing.sort_of env evdref t in - let () = match body with - | None -> () - | Some body -> Typing.check env evdref body t + let () = match decl with + | LocalAssum _ -> () + | LocalDef (_,body,_) -> Typing.check env evdref body t in (!evdref, Environ.push_named decl env) in diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 8d6bdf6aec..186525e159 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -13,7 +13,7 @@ open Evd open Environ open Proof_type open Logic - +open Context.Named.Declaration let sig_it x = x.it let project x = x.sigma @@ -202,7 +202,7 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) let { it = gls; sigma = sigma; } = rslt in let hyps:Context.Named.t list = List.map (fun gl -> pf_hyps { it = gl; sigma=sigma; }) gls in - let cmp (i1, c1, t1) (i2, c2, t2) = Names.Id.equal i1 i2 in + let cmp d1 d2 = Names.Id.equal (get_id d1) (get_id d2) in let newhyps = List.map (fun hypl -> List.subtract cmp hypl oldhyps) @@ -215,7 +215,7 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) List.fold_left (fun acc lh -> acc ^ (if !frst then (frst:=false;"") else " | ") ^ (List.fold_left - (fun acc (nm,_,_) -> (Names.Id.to_string nm) ^ " " ^ acc) + (fun acc d -> (Names.Id.to_string (get_id d)) ^ " " ^ acc) "" lh)) "" newhyps in pp (str (emacs_str "") diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index a1ebacea84..429bd27742 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -18,6 +18,7 @@ open Tacred open Proof_type open Logic open Refiner +open Context.Named.Declaration let re_sig it gc = { it = it; sigma = gc; } @@ -40,9 +41,11 @@ let pf_hyps = Refiner.pf_hyps 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 + List.map (function LocalAssum (id,x) + | LocalDef (id,_,x) -> id, x) + sign -let pf_nth_hyp_id gls n = let (id,c,t) = List.nth (pf_hyps gls) (n-1) in id +let pf_nth_hyp_id gls n = List.nth (pf_hyps gls) (n-1) |> get_id let pf_last_hyp gl = List.hd (pf_hyps gl) @@ -53,8 +56,7 @@ let pf_get_hyp gls id = raise (RefinerError (NoSuchHyp id)) let pf_get_hyp_typ gls id = - let (_,_,ty)= (pf_get_hyp gls id) in - ty + pf_get_hyp gls id |> get_type let pf_ids_of_hyps gls = ids_of_named_context (pf_hyps gls) @@ -204,13 +206,14 @@ module New = struct sign let pf_get_hyp_typ id gl = - let (_,_,ty) = pf_get_hyp id gl in - ty + pf_get_hyp id gl |> get_type let pf_hyps_types gl = let env = Proofview.Goal.env gl in let sign = Environ.named_context env in - List.map (fun (id,_,x) -> (id, x)) sign + List.map (function LocalAssum (id,x) + | LocalDef (id,_,x) -> id, x) + sign let pf_last_hyp gl = let hyps = Proofview.Goal.hyps gl in -- cgit v1.2.3 From f46a5686853353f8de733ae7fbd21a3a61977bc7 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 3 Feb 2016 15:32:58 +0100 Subject: Do not give a name to anonymous evars anymore. See bug #4547. The current solution may not be totally ideal though. We generate names for anonymous evars on the fly at printing time, based on the Evar_kind data they are wearing. This means in particular that the printed name of an anonymous evar may change in the future because some unrelate evar has been solved or introduced. --- proofs/goal.ml | 5 ++++- proofs/proofview.ml | 5 ++++- 2 files changed, 8 insertions(+), 2 deletions(-) (limited to 'proofs') diff --git a/proofs/goal.ml b/proofs/goal.ml index 1dd5be0e71..43a3024e50 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -89,7 +89,10 @@ module V82 = struct (* Instantiates a goal with an open term, using name of goal for evk' *) let partial_solution_to sigma evk evk' c = let id = Evd.evar_ident evk sigma in - Evd.rename evk' id (partial_solution sigma evk c) + let sigma = partial_solution sigma evk c in + match id with + | None -> sigma + | Some id -> Evd.rename evk' id sigma (* Parts of the progress tactical *) let same_goal evars1 gl1 evars2 gl2 = diff --git a/proofs/proofview.ml b/proofs/proofview.ml index a6d9735f14..49228c93ac 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -1093,7 +1093,10 @@ struct | None -> Evd.define gl.Goal.self c sigma | Some evk -> let id = Evd.evar_ident gl.Goal.self sigma in - Evd.rename evk id (Evd.define gl.Goal.self c sigma) + let sigma = Evd.define gl.Goal.self c sigma in + match id with + | None -> sigma + | Some id -> Evd.rename evk id sigma in (** Restore the [future goals] state. *) let sigma = Evd.restore_future_goals sigma prev_future_goals prev_principal_goal in -- cgit v1.2.3 From 968dfdb15cc11d48783017b2a91147b25c854ad6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 1 Dec 2015 19:45:01 +0100 Subject: Monotonizing the Evarutil module. Some functions were left in the old paradigm because they are only used by the unification algorithms, so they are not worthwhile to change for now. --- proofs/goal.ml | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) (limited to 'proofs') diff --git a/proofs/goal.ml b/proofs/goal.ml index 43a3024e50..1251dacd5d 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -9,6 +9,7 @@ open Util open Pp open Term +open Sigma.Notations (* This module implements the abstract interface to goals *) (* A general invariant of the module, is that a goal whose associated @@ -70,7 +71,9 @@ module V82 = struct Evd.evar_extra = extra } in let evi = Typeclasses.mark_unresolvable evi in - let (evars, evk) = Evarutil.new_pure_evar_full evars evi in + let evars = Sigma.Unsafe.of_evar_map evars in + let Sigma (evk, evars, _) = Evarutil.new_pure_evar_full evars evi in + let evars = Sigma.to_evar_map evars in let evars = Evd.restore_future_goals evars prev_future_goals prev_principal_goal in let ctxt = Environ.named_context_of_val hyps in let inst = Array.map_of_list (fun (id, _, _) -> mkVar id) ctxt in @@ -126,8 +129,10 @@ module V82 = struct let new_evi = { evi with Evd.evar_hyps = new_hyps; Evd.evar_filter = new_filter } in let new_evi = Typeclasses.mark_unresolvable new_evi in - let (new_sigma, evk) = Evarutil.new_pure_evar_full Evd.empty new_evi in - { Evd.it = evk ; sigma = new_sigma; } + let sigma = Sigma.Unsafe.of_evar_map Evd.empty in + let Sigma (evk, sigma, _) = Evarutil.new_pure_evar_full sigma new_evi in + let sigma = Sigma.to_evar_map sigma in + { Evd.it = evk ; sigma = sigma; } (* Used by the compatibility layer and typeclasses *) let nf_evar sigma gl = -- cgit v1.2.3 From 1a8c37ca352c95b4cd530efbbf47f0e7671d1fb3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 15 Feb 2016 13:31:54 +0100 Subject: Renaming functions in Typing to stick to the standard e_* scheme. --- proofs/proofview.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'proofs') diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 8008b00253..38e9cafad1 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -1077,10 +1077,10 @@ struct (** Typecheck the hypotheses. *) let type_hyp (sigma, env) (na, body, t as decl) = let evdref = ref sigma in - let _ = Typing.sort_of env evdref t in + let _ = Typing.e_sort_of env evdref t in let () = match body with | None -> () - | Some body -> Typing.check env evdref body t + | Some body -> Typing.e_check env evdref body t in (!evdref, Environ.push_named decl env) in @@ -1089,12 +1089,12 @@ struct let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in (** Typecheck the conclusion *) let evdref = ref sigma in - let _ = Typing.sort_of env evdref (Evd.evar_concl info) in + let _ = Typing.e_sort_of env evdref (Evd.evar_concl info) in !evdref let typecheck_proof c concl env sigma = let evdref = ref sigma in - let () = Typing.check env evdref c concl in + let () = Typing.e_check env evdref c concl in !evdref let (pr_constrv,pr_constr) = -- cgit v1.2.3 From 5180ab68819f10949cd41a2458bff877b3ec3204 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 15 Feb 2016 16:45:18 +0100 Subject: Using monotonic types for conversion functions. --- proofs/redexpr.ml | 2 +- proofs/tacmach.ml | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) (limited to 'proofs') diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 818805a56c..2d886b8e1f 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -194,7 +194,7 @@ let out_arg = function let out_with_occurrences (occs,c) = (Locusops.occurrences_map (List.map out_arg) occs, c) -let e_red f env evm c = evm, f env evm c +let e_red f = { e_redfun = fun env evm c -> Sigma.here (f env (Sigma.to_evar_map evm) c) evm } let head_style = false (* Turn to true to have a semantics where simpl only reduce at the head when an evaluable reference is given, e.g. diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index a1ebacea84..a10d8fd2f7 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -18,6 +18,7 @@ open Tacred open Proof_type open Logic open Refiner +open Sigma.Notations let re_sig it gc = { it = it; sigma = gc; } @@ -70,7 +71,10 @@ let pf_get_new_ids ids gls = let pf_global gls id = Constrintern.construct_reference (pf_hyps gls) id let pf_reduction_of_red_expr gls re c = - (fst (reduction_of_red_expr (pf_env gls) re)) (pf_env gls) (project gls) c + let (redfun, _) = reduction_of_red_expr (pf_env gls) re in + let sigma = Sigma.Unsafe.of_evar_map (project gls) in + let Sigma (c, sigma, _) = redfun.e_redfun (pf_env gls) sigma c in + (Sigma.to_evar_map sigma, c) let pf_apply f gls = f (pf_env gls) (project gls) let pf_eapply f gls x = -- cgit v1.2.3 From 06fa0334047a9400d0b5a144601fca35746a53b8 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 17 Feb 2016 10:32:40 +0100 Subject: CLEANUP: Renaming "Util.compose" function to "%" I propose to change the name of the "Util.compose" function to "%". Reasons: 1. If one wants to express function composition, then the new name enables us to achieve this goal easier. 2. In "Batteries Included" they had made the same choice. --- proofs/tacmach.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'proofs') diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index a10d8fd2f7..1e59c182ce 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -99,7 +99,7 @@ let pf_const_value = pf_reduce (fun env _ -> constant_value_in env) let pf_reduce_to_quantified_ind = pf_reduce reduce_to_quantified_ind let pf_reduce_to_atomic_ind = pf_reduce reduce_to_atomic_ind -let pf_hnf_type_of gls = compose (pf_whd_betadeltaiota gls) (pf_get_type_of gls) +let pf_hnf_type_of gls = pf_whd_betadeltaiota gls % pf_get_type_of gls let pf_is_matching = pf_apply Constr_matching.is_matching_conv let pf_matches = pf_apply Constr_matching.matches_conv -- cgit v1.2.3 From 8a179389fe5199e79d05b2c72ff2aae2061820aa Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 17 Feb 2016 18:53:45 +0100 Subject: Fixing the Proofview.Goal.goal function. The environment put in the goals was not the right one and could lead to various leaks. --- proofs/proofview.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'proofs') diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 49228c93ac..6d7dcb9257 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -1000,7 +1000,6 @@ module Goal = struct end let goals = - Env.get >>= fun env -> Pv.get >>= fun step -> let sigma = step.solution in let map goal = @@ -1008,6 +1007,7 @@ module Goal = struct | None -> None (** ppedrot: Is this check really necessary? *) | Some goal -> let gl = + Env.get >>= fun env -> tclEVARMAP >>= fun sigma -> tclUNIT (gmake env sigma goal) in -- cgit v1.2.3 From b98e4857a13a4014c65882af5321ebdb09f41890 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 4 Mar 2016 17:40:10 +0100 Subject: Rename Ephemeron -> CEphemeron. Fixes compilation of Coq with OCaml 4.03 beta 1. --- proofs/proof_global.ml | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) (limited to 'proofs') diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index f22cdbcc8e..541f299d4f 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -36,7 +36,7 @@ let find_proof_mode n = Errors.error (Format.sprintf "No proof mode named \"%s\"." n) let register_proof_mode ({name = n} as m) = - Hashtbl.add proof_modes n (Ephemeron.create m) + Hashtbl.add proof_modes n (CEphemeron.create m) (* initial mode: standard mode *) let standard = { name = "No" ; set = (fun ()->()) ; reset = (fun () -> ()) } @@ -52,7 +52,7 @@ let _ = optname = "default proof mode" ; optkey = ["Default";"Proof";"Mode"] ; optread = begin fun () -> - (Ephemeron.default !default_proof_mode standard).name + (CEphemeron.default !default_proof_mode standard).name end; optwrite = begin fun n -> default_proof_mode := find_proof_mode n @@ -83,12 +83,12 @@ type closed_proof = proof_object * proof_terminator type pstate = { pid : Id.t; - terminator : proof_terminator Ephemeron.key; + terminator : proof_terminator CEphemeron.key; endline_tactic : Tacexpr.raw_tactic_expr option; section_vars : Context.section_context option; proof : Proof.proof; strength : Decl_kinds.goal_kind; - mode : proof_mode Ephemeron.key; + mode : proof_mode CEphemeron.key; universe_binders: universe_binders option; } @@ -103,11 +103,11 @@ let current_proof_mode = ref !default_proof_mode let update_proof_mode () = match !pstates with | { mode = m } :: _ -> - Ephemeron.iter_opt !current_proof_mode (fun x -> x.reset ()); + CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ()); current_proof_mode := m; - Ephemeron.iter_opt !current_proof_mode (fun x -> x.set ()) + CEphemeron.iter_opt !current_proof_mode (fun x -> x.set ()) | _ -> - Ephemeron.iter_opt !current_proof_mode (fun x -> x.reset ()); + CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ()); current_proof_mode := find_proof_mode "No" (* combinators for the current_proof lists *) @@ -215,9 +215,9 @@ let set_proof_mode mn = set_proof_mode (find_proof_mode mn) (get_current_proof_name ()) let activate_proof_mode mode = - Ephemeron.iter_opt (find_proof_mode mode) (fun x -> x.set ()) + CEphemeron.iter_opt (find_proof_mode mode) (fun x -> x.set ()) let disactivate_proof_mode mode = - Ephemeron.iter_opt (find_proof_mode mode) (fun x -> x.reset ()) + CEphemeron.iter_opt (find_proof_mode mode) (fun x -> x.reset ()) (** [start_proof sigma id str goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and @@ -230,7 +230,7 @@ let disactivate_proof_mode mode = let start_proof sigma id ?pl str goals terminator = let initial_state = { pid = id; - terminator = Ephemeron.create terminator; + terminator = CEphemeron.create terminator; proof = Proof.start sigma goals; endline_tactic = None; section_vars = None; @@ -242,7 +242,7 @@ let start_proof sigma id ?pl str goals terminator = let start_dependent_proof id ?pl str goals terminator = let initial_state = { pid = id; - terminator = Ephemeron.create terminator; + terminator = CEphemeron.create terminator; proof = Proof.dependent_start goals; endline_tactic = None; section_vars = None; @@ -375,7 +375,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = in { id = pid; entries = entries; persistence = strength; universes = (universes, binders) }, - fun pr_ending -> Ephemeron.get terminator pr_ending + fun pr_ending -> CEphemeron.get terminator pr_ending type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context @@ -423,11 +423,11 @@ let close_proof ~keep_body_ucst_separate fix_exn = (** Gets the current terminator without checking that the proof has been completed. Useful for the likes of [Admitted]. *) -let get_terminator () = Ephemeron.get ( cur_pstate() ).terminator +let get_terminator () = CEphemeron.get ( cur_pstate() ).terminator let set_terminator hook = match !pstates with | [] -> raise NoCurrentProof - | p :: ps -> pstates := { p with terminator = Ephemeron.create hook } :: ps + | p :: ps -> pstates := { p with terminator = CEphemeron.create hook } :: ps -- cgit v1.2.3 From 6ecbc9990a49a0dd51970c7fc8b13f39f02be773 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Mar 2016 18:34:39 +0100 Subject: Moving Ltac traces to Tacexpr and Tacinterp. --- proofs/proof_type.ml | 52 --------------------------------------------------- proofs/proof_type.mli | 16 ---------------- proofs/proofs.mllib | 1 - 3 files changed, 69 deletions(-) delete mode 100644 proofs/proof_type.ml (limited to 'proofs') diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml deleted file mode 100644 index dd2c7b253d..0000000000 --- a/proofs/proof_type.ml +++ /dev/null @@ -1,52 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* goal list sigma - -type prim_rule = - | Cut of bool * bool * Id.t * types - | FixRule of Id.t * int * (Id.t * int * constr) list * int - | Cofix of Id.t * (Id.t * constr) list * int - | Refine of constr - | Thin of Id.t list - | Move of Id.t * Id.t move_location - -(** Nowadays, the only rules we'll consider are the primitive rules *) - -type rule = prim_rule - -(** Ltac traces *) - -type ltac_call_kind = - | LtacMLCall of glob_tactic_expr - | LtacNotationCall of KerName.t - | LtacNameCall of ltac_constant - | LtacAtomCall of glob_atomic_tactic_expr - | LtacVarCall of Id.t * glob_tactic_expr - | LtacConstrInterp of glob_constr * Pretyping.ltac_var_map - -type ltac_trace = (Loc.t * ltac_call_kind) list - -let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make () diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli index aa05f58ab6..b4c9dae2a3 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.mli @@ -57,19 +57,3 @@ type rule = prim_rule type goal = Goal.goal type tactic = goal sigma -> goal list sigma - -(** Ltac traces *) - -(** TODO: Move those definitions somewhere sensible *) - -type ltac_call_kind = - | LtacMLCall of glob_tactic_expr - | LtacNotationCall of KerName.t - | LtacNameCall of ltac_constant - | LtacAtomCall of glob_atomic_tactic_expr - | LtacVarCall of Id.t * glob_tactic_expr - | LtacConstrInterp of glob_constr * Pretyping.ltac_var_map - -type ltac_trace = (Loc.t * ltac_call_kind) list - -val ltac_trace_info : ltac_trace Exninfo.t diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 1bd701cb9b..47a637575f 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -2,7 +2,6 @@ Miscprint Goal Evar_refiner Proof_using -Proof_type Proof_errors Logic Proofview -- cgit v1.2.3 From 9e96794d6a4327761ce1ff992351199919431be1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Mar 2016 19:01:38 +0100 Subject: Moving Tactic_debug to tactics/ folder. --- proofs/proofs.mllib | 1 - proofs/tactic_debug.ml | 319 ------------------------------------------------ proofs/tactic_debug.mli | 79 ------------ 3 files changed, 399 deletions(-) delete mode 100644 proofs/tactic_debug.ml delete mode 100644 proofs/tactic_debug.mli (limited to 'proofs') diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 47a637575f..08556d62ec 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -11,6 +11,5 @@ Redexpr Refiner Tacmach Pfedit -Tactic_debug Clenv Clenvtac diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml deleted file mode 100644 index d33278ff8d..0000000000 --- a/proofs/tactic_debug.ml +++ /dev/null @@ -1,319 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* mt()) - -let explain_logic_error_no_anomaly = ref (fun e -> mt()) - -let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) -let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) - -(* Prints the goal *) - -let db_pr_goal gl = - let env = Proofview.Goal.env gl in - let concl = Proofview.Goal.concl gl in - let penv = print_named_context env in - let pc = print_constr_env env concl in - str" " ++ hv 0 (penv ++ fnl () ++ - str "============================" ++ fnl () ++ - str" " ++ pc) ++ fnl () - -let db_pr_goal = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let pg = db_pr_goal gl in - Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) - end } - - -(* Prints the commands *) -let help () = - msg_tac_debug (str "Commands: = Continue" ++ fnl() ++ - str " h/? = Help" ++ fnl() ++ - str " r = Run times" ++ fnl() ++ - str " r = Run up to next idtac " ++ fnl() ++ - str " s = Skip" ++ fnl() ++ - str " x = Exit") - -(* Prints the goal and the command to be executed *) -let goal_com tac = - Proofview.tclTHEN - db_pr_goal - (Proofview.tclLIFT (msg_tac_debug (str "Going to execute:" ++ fnl () ++ Hook.get prtac tac))) - -(* [run (new_ref _)] gives us a ref shared among [NonLogical.t] - expressions. It avoids parametrizing everything over a - reference. *) -let skipped = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) -let skip = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) -let breakpoint = Proofview.NonLogical.run (Proofview.NonLogical.ref None) - -let rec drop_spaces inst i = - if String.length inst > i && inst.[i] == ' ' then drop_spaces inst (i+1) - else i - -let possibly_unquote s = - if String.length s >= 2 && s.[0] == '"' && s.[String.length s - 1] == '"' then - String.sub s 1 (String.length s - 2) - else - s - -(* (Re-)initialize debugger *) -let db_initialize = - let open Proofview.NonLogical in - (skip:=0) >> (skipped:=0) >> (breakpoint:=None) - -let int_of_string s = - try Proofview.NonLogical.return (int_of_string s) - with e -> Proofview.NonLogical.raise e - -let string_get s i = - try Proofview.NonLogical.return (String.get s i) - with e -> Proofview.NonLogical.raise e - -(* Gives the number of steps or next breakpoint of a run command *) -let run_com inst = - let open Proofview.NonLogical in - string_get inst 0 >>= fun first_char -> - if first_char ='r' then - let i = drop_spaces inst 1 in - if String.length inst > i then - let s = String.sub inst i (String.length inst - i) in - if inst.[0] >= '0' && inst.[0] <= '9' then - int_of_string s >>= fun num -> - (if num<0 then invalid_arg "run_com" else return ()) >> - (skip:=num) >> (skipped:=0) - else - breakpoint:=Some (possibly_unquote s) - else - invalid_arg "run_com" - else - invalid_arg "run_com" - -(* Prints the run counter *) -let run ini = - let open Proofview.NonLogical in - if not ini then - begin - Proofview.NonLogical.print_notice (str"\b\r\b\r") >> - !skipped >>= fun skipped -> - msg_tac_debug (str "Executed expressions: " ++ int skipped ++ fnl()) - end >> - !skipped >>= fun x -> - skipped := x+1 - else - return () - -(* Prints the prompt *) -let rec prompt level = - (* spiwack: avoid overriding by the open below *) - let runtrue = run true in - begin - let open Proofview.NonLogical in - Proofview.NonLogical.print_notice (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >> - let exit = (skip:=0) >> (skipped:=0) >> raise Sys.Break in - Proofview.NonLogical.catch Proofview.NonLogical.read_line - begin function (e, info) -> match e with - | End_of_file -> exit - | e -> raise ~info e - end - >>= fun inst -> - match inst with - | "" -> return (DebugOn (level+1)) - | "s" -> return (DebugOff) - | "x" -> Proofview.NonLogical.print_char '\b' >> exit - | "h"| "?" -> - begin - help () >> - prompt level - end - | _ -> - Proofview.NonLogical.catch (run_com inst >> runtrue >> return (DebugOn (level+1))) - begin function (e, info) -> match e with - | Failure _ | Invalid_argument _ -> prompt level - | e -> raise ~info e - end - end - -(* Prints the state and waits for an instruction *) -(* spiwack: the only reason why we need to take the continuation [f] - as an argument rather than returning the new level directly seems to - be that [f] is wrapped in with "explain_logic_error". I don't think - it serves any purpose in the current design, so we could just drop - that. *) -let debug_prompt lev tac f = - (* spiwack: avoid overriding by the open below *) - let runfalse = run false in - let open Proofview.NonLogical in - let (>=) = Proofview.tclBIND in - (* What to print and to do next *) - let newlevel = - Proofview.tclLIFT !skip >= fun initial_skip -> - if Int.equal initial_skip 0 then - Proofview.tclLIFT !breakpoint >= fun breakpoint -> - if Option.is_empty breakpoint then Proofview.tclTHEN (goal_com tac) (Proofview.tclLIFT (prompt lev)) - else Proofview.tclLIFT(runfalse >> return (DebugOn (lev+1))) - else Proofview.tclLIFT begin - (!skip >>= fun s -> skip:=s-1) >> - runfalse >> - !skip >>= fun new_skip -> - (if Int.equal new_skip 0 then skipped:=0 else return ()) >> - return (DebugOn (lev+1)) - end in - newlevel >= fun newlevel -> - (* What to execute *) - Proofview.tclOR - (f newlevel) - begin fun (reraise, info) -> - Proofview.tclTHEN - (Proofview.tclLIFT begin - (skip:=0) >> (skipped:=0) >> - if Logic.catchable_exception reraise then - msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ Pervasives.(!) explain_logic_error reraise) - else return () - end) - (Proofview.tclZERO ~info reraise) - end - -let is_debug db = - let open Proofview.NonLogical in - !breakpoint >>= fun breakpoint -> - match db, breakpoint with - | DebugOff, _ -> return false - | _, Some _ -> return false - | _ -> - !skip >>= fun skip -> - return (Int.equal skip 0) - -(* Prints a constr *) -let db_constr debug env c = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "Evaluated term: " ++ print_constr_env env c) - else return () - -(* Prints the pattern rule *) -let db_pattern_rule debug num r = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - begin - msg_tac_debug (str "Pattern rule " ++ int num ++ str ":" ++ fnl () ++ - str "|" ++ spc () ++ Hook.get prmatchrl r) - end - else return () - -(* Prints the hypothesis pattern identifier if it exists *) -let hyp_bound = function - | Anonymous -> str " (unbound)" - | Name id -> str " (bound to " ++ pr_id id ++ str ")" - -(* Prints a matched hypothesis *) -let db_matched_hyp debug env (id,_,c) ido = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "Hypothesis " ++ pr_id id ++ hyp_bound ido ++ - str " has been matched: " ++ print_constr_env env c) - else return () - -(* Prints the matched conclusion *) -let db_matched_concl debug env c = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "Conclusion has been matched: " ++ print_constr_env env c) - else return () - -(* Prints a success message when the goal has been matched *) -let db_mc_pattern_success debug = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "The goal has been successfully matched!" ++ fnl() ++ - str "Let us execute the right-hand side part..." ++ fnl()) - else return () - -(* Prints a failure message for an hypothesis pattern *) -let db_hyp_pattern_failure debug env sigma (na,hyp) = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "The pattern hypothesis" ++ hyp_bound na ++ - str " cannot match: " ++ - Hook.get prmatchpatt env sigma hyp) - else return () - -(* Prints a matching failure message for a rule *) -let db_matching_failure debug = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "This rule has failed due to matching errors!" ++ fnl() ++ - str "Let us try the next one...") - else return () - -(* Prints an evaluation failure message for a rule *) -let db_eval_failure debug s = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - let s = str "message \"" ++ s ++ str "\"" in - msg_tac_debug - (str "This rule has failed due to \"Fail\" tactic (" ++ - s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...") - else return () - -(* Prints a logic failure message for a rule *) -let db_logic_failure debug err = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - begin - msg_tac_debug (Pervasives.(!) explain_logic_error err) >> - msg_tac_debug (str "This rule has failed due to a logic error!" ++ fnl() ++ - str "Let us try the next one...") - end - else return () - -let is_breakpoint brkname s = match brkname, s with - | Some s, MsgString s'::_ -> String.equal s s' - | _ -> false - -let db_breakpoint debug s = - let open Proofview.NonLogical in - !breakpoint >>= fun opt_breakpoint -> - match debug with - | DebugOn lev when not (CList.is_empty s) && is_breakpoint opt_breakpoint s -> - breakpoint:=None - | _ -> - return () diff --git a/proofs/tactic_debug.mli b/proofs/tactic_debug.mli deleted file mode 100644 index 215c5b29b5..0000000000 --- a/proofs/tactic_debug.mli +++ /dev/null @@ -1,79 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.std_ppcmds) Hook.t -val match_pattern_printer : - (env -> evar_map -> constr_pattern match_pattern -> Pp.std_ppcmds) Hook.t -val match_rule_printer : - ((Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> Pp.std_ppcmds) Hook.t - -(** Debug information *) -type debug_info = - | DebugOn of int - | DebugOff - -(** Prints the state and waits *) -val debug_prompt : - int -> glob_tactic_expr -> (debug_info -> 'a Proofview.tactic) -> 'a Proofview.tactic - -(** Initializes debugger *) -val db_initialize : unit Proofview.NonLogical.t - -(** Prints a constr *) -val db_constr : debug_info -> env -> constr -> unit Proofview.NonLogical.t - -(** Prints the pattern rule *) -val db_pattern_rule : - debug_info -> int -> (Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t - -(** Prints a matched hypothesis *) -val db_matched_hyp : - debug_info -> env -> Id.t * constr option * constr -> Name.t -> unit Proofview.NonLogical.t - -(** Prints the matched conclusion *) -val db_matched_concl : debug_info -> env -> constr -> unit Proofview.NonLogical.t - -(** Prints a success message when the goal has been matched *) -val db_mc_pattern_success : debug_info -> unit Proofview.NonLogical.t - -(** Prints a failure message for an hypothesis pattern *) -val db_hyp_pattern_failure : - debug_info -> env -> evar_map -> Name.t * constr_pattern match_pattern -> unit Proofview.NonLogical.t - -(** Prints a matching failure message for a rule *) -val db_matching_failure : debug_info -> unit Proofview.NonLogical.t - -(** Prints an evaluation failure message for a rule *) -val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit Proofview.NonLogical.t - -(** An exception handler *) -val explain_logic_error: (exn -> Pp.std_ppcmds) ref - -(** For use in the Ltac debugger: some exception that are usually - consider anomalies are acceptable because they are caught later in - the process that is being debugged. One should not require - from users that they report these anomalies. *) -val explain_logic_error_no_anomaly : (exn -> Pp.std_ppcmds) ref - -(** Prints a logic failure message for a rule *) -val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t - -(** Prints a logic failure message for a rule *) -val db_breakpoint : debug_info -> - Id.t Loc.located message_token list -> unit Proofview.NonLogical.t -- cgit v1.2.3 From 6caf8b877e44862b21104236423c23972166cdd7 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 14 Mar 2016 11:14:03 +0100 Subject: Fix the comment of Refine.refine --- proofs/proofview.mli | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'proofs') diff --git a/proofs/proofview.mli b/proofs/proofview.mli index dc97e44b6f..7f95a053a8 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -505,9 +505,9 @@ module Refine : sig (** In [refine ?unsafe t], [t] is a term with holes under some [evar_map] context. The term [t] is used as a partial solution for the current goal (refine is a goal-dependent tactic), the - new holes created by [t] become the new subgoals. Exception + new holes created by [t] become the new subgoals. Exceptions raised during the interpretation of [t] are caught and result in - tactic failures. If [unsafe] is [true] (default) [t] is + tactic failures. If [unsafe] is [false] (default is [true]) [t] is type-checked beforehand. *) (** {7 Helper functions} *) -- cgit v1.2.3 From 5bce635ad876bde78a7ffabc3e781112e5418a65 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 15 Mar 2016 23:56:22 +0100 Subject: Removing the dependency in VernacSolve in the STM. Instead of mangling the AST in order to interpret par: we remember the goal position to focus on it first and evaluate then the underlying vernacular expression. --- proofs/pfedit.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'proofs') diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 20d696fd91..0fdcaa5875 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -104,9 +104,7 @@ let solve ?with_end_tac gi info_lvl tac pr = let tac = match gi with | Vernacexpr.SelectNth i -> Proofview.tclFOCUS i i tac | Vernacexpr.SelectId id -> Proofview.tclFOCUSID id tac - | Vernacexpr.SelectAll -> tac - | Vernacexpr.SelectAllParallel -> - Errors.anomaly(str"SelectAllParallel not handled by Stm") + | Vernacexpr.SelectAll | Vernacexpr.SelectAllParallel -> tac in let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac pr in let () = -- cgit v1.2.3 From ce2ffd090bd64963279cbbb84012d1b266ed9918 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Mar 2016 01:43:29 +0100 Subject: Moving VernacSolve to an EXTEND-based definition. --- proofs/pfedit.ml | 2 +- proofs/proof_global.ml | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) (limited to 'proofs') diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 0fdcaa5875..608ee2c700 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -104,7 +104,7 @@ let solve ?with_end_tac gi info_lvl tac pr = let tac = match gi with | Vernacexpr.SelectNth i -> Proofview.tclFOCUS i i tac | Vernacexpr.SelectId id -> Proofview.tclFOCUSID id tac - | Vernacexpr.SelectAll | Vernacexpr.SelectAllParallel -> tac + | Vernacexpr.SelectAll -> tac in let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac pr in let () = diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index d19dc5ba0f..647dbe1115 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -664,7 +664,6 @@ let print_goal_selector = function | Vernacexpr.SelectAll -> "all" | Vernacexpr.SelectNth i -> string_of_int i | Vernacexpr.SelectId id -> Id.to_string id - | Vernacexpr.SelectAllParallel -> "par" let parse_goal_selector = function | "all" -> Vernacexpr.SelectAll -- cgit v1.2.3 From 48e4831fa56e3b0acd92aabdb78847696b84daf7 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 17:33:26 +0100 Subject: Extruding the code for the Existential command from Proofview. --- proofs/evar_refiner.ml | 11 ----------- proofs/evar_refiner.mli | 5 ----- proofs/proof.ml | 22 ++++++++++++++++++++-- proofs/proofview.ml | 14 -------------- proofs/proofview.mli | 3 --- 5 files changed, 20 insertions(+), 35 deletions(-) (limited to 'proofs') diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 059ae54c9d..3192a6a29a 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -59,14 +59,3 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = str (string_of_existential evk)) in define_and_solve_constraints evk typed_c env (evars_reset_evd sigma' sigma) - -(* vernac command Existential *) - -(* Main component of vernac command Existential *) -let instantiate_pf_com evk com sigma = - let evi = Evd.find sigma evk in - let env = Evd.evar_filtered_env evi in - let rawc = Constrintern.intern_constr env com in - let ltac_vars = Pretyping.empty_lvar in - let sigma' = w_refine (evk, evi) (ltac_vars, rawc) sigma in - sigma' diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli index 35a3e5d828..e3778e94c9 100644 --- a/proofs/evar_refiner.mli +++ b/proofs/evar_refiner.mli @@ -13,8 +13,3 @@ open Pretyping val w_refine : evar * evar_info -> glob_constr_ltac_closure -> evar_map -> evar_map - -val instantiate_pf_com : - Evd.evar -> Constrexpr.constr_expr -> Evd.evar_map -> Evd.evar_map - -(** the instantiate tactic was moved to [tactics/evar_tactics.ml] *) diff --git a/proofs/proof.ml b/proofs/proof.ml index 0489305aa7..b604fde4eb 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -387,9 +387,27 @@ module V82 = struct { p with proofview = Proofview.V82.grab p.proofview } + (* Main component of vernac command Existential *) let instantiate_evar n com pr = - let sp = pr.proofview in - let proofview = Proofview.V82.instantiate_evar n com sp in + let tac = + Proofview.tclBIND Proofview.tclEVARMAP begin fun sigma -> + let (evk, evi) = + let evl = Evarutil.non_instantiated sigma in + let evl = Evar.Map.bindings evl in + if (n <= 0) then + Errors.error "incorrect existential variable index" + else if CList.length evl < n then + Errors.error "not so many uninstantiated existential variables" + else + CList.nth evl (n-1) + in + let env = Evd.evar_filtered_env evi in + let rawc = Constrintern.intern_constr env com in + let ltac_vars = Pretyping.empty_lvar in + let sigma = Evar_refiner.w_refine (evk, evi) (ltac_vars, rawc) sigma in + Proofview.Unsafe.tclEVARS sigma + end in + let ((), proofview, _, _) = Proofview.apply (Global.env ()) tac pr.proofview in let shelf = List.filter begin fun g -> Evd.is_undefined (Proofview.return proofview) g diff --git a/proofs/proofview.ml b/proofs/proofview.ml index a382e9873f..b68fa042e3 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -1272,20 +1272,6 @@ module V82 = struct in CList.flatten (CList.map evars_of_initial initial) - let instantiate_evar n com pv = - let (evk,_) = - let evl = Evarutil.non_instantiated pv.solution in - let evl = Evar.Map.bindings evl in - if (n <= 0) then - Errors.error "incorrect existential variable index" - else if CList.length evl < n then - Errors.error "not so many uninstantiated existential variables" - else - CList.nth evl (n-1) - in - { pv with - solution = Evar_refiner.instantiate_pf_com evk com pv.solution } - let of_tactic t gls = try let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 7f95a053a8..61014468b5 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -577,9 +577,6 @@ module V82 : sig (* returns the existential variable used to start the proof *) val top_evars : entry -> Evd.evar list - - (* Implements the Existential command *) - val instantiate_evar : int -> Constrexpr.constr_expr -> proofview -> proofview (* Caution: this function loses quite a bit of information. It should be avoided as much as possible. It should work as -- cgit v1.2.3 From 32bf41967bbcd2bf21dea8a6b4f5f500eb15aacc Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 18:01:07 +0100 Subject: Making Proofview independent from Goal. --- proofs/proofview.ml | 24 ++++++++++++++++++------ 1 file changed, 18 insertions(+), 6 deletions(-) (limited to 'proofs') diff --git a/proofs/proofview.ml b/proofs/proofview.ml index b68fa042e3..2a09d52f7d 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -924,8 +924,20 @@ let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) (** {6 Goal-dependent tactics} *) -(* To avoid shadowing by the local [Goal] module *) -module GoalV82 = Goal.V82 +let goal_env evars gl = + let evi = Evd.find evars gl in + Evd.evar_filtered_env evi + +let goal_nf_evar sigma gl = + let evi = Evd.find sigma gl in + let evi = Evarutil.nf_evar_info sigma evi in + let sigma = Evd.add sigma gl evi in + (gl, sigma) + +let goal_extra evars gl = + let evi = Evd.find evars gl in + evi.Evd.evar_extra + let catchable_exception = function | Logic_monad.Exception _ -> false @@ -950,7 +962,7 @@ module Goal = struct let sigma { sigma=sigma } = Sigma.Unsafe.of_evar_map sigma let hyps { env=env } = Environ.named_context env let concl { concl=concl } = concl - let extra { sigma=sigma; self=self } = Goal.V82.extra sigma self + let extra { sigma=sigma; self=self } = goal_extra sigma self let raw_concl { concl=concl } = concl @@ -1225,7 +1237,7 @@ module V82 = struct in (* Old style tactics expect the goals normalized with respect to evars. *) let (initgoals,initevd) = - Evd.Monad.List.map (fun g s -> GoalV82.nf_evar s g) ps.comb ps.solution + Evd.Monad.List.map (fun g s -> goal_nf_evar s g) ps.comb ps.solution in let (goalss,evd) = Evd.Monad.List.map tac initgoals initevd in let sgs = CList.flatten goalss in @@ -1241,7 +1253,7 @@ module V82 = struct solution. *) let nf_evar_goals = Pv.modify begin fun ps -> - let map g s = GoalV82.nf_evar s g in + let map g s = goal_nf_evar s g in let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in { ps with solution = evd; comb = goals; } end @@ -1275,7 +1287,7 @@ module V82 = struct let of_tactic t gls = try let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in - let (_,final,_,_) = apply (GoalV82.env gls.Evd.sigma gls.Evd.it) t init in + let (_,final,_,_) = apply (goal_env gls.Evd.sigma gls.Evd.it) t init in { Evd.sigma = final.solution ; it = final.comb } with Logic_monad.TacticFailure e as src -> let (_, info) = Errors.push src in -- cgit v1.2.3 From b2a2cb77f38549a25417d199e90d745715f3e465 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 18:08:42 +0100 Subject: Making Proofview independent of Logic. --- proofs/proofview.ml | 6 +++--- proofs/proofview.mli | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) (limited to 'proofs') diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 2a09d52f7d..f42a60d9db 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -625,18 +625,18 @@ let shelve_unifiable = InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >> Shelf.modify (fun gls -> gls @ u) -(** [guard_no_unifiable] fails with error [UnresolvedBindings] if some +(** [guard_no_unifiable] returns the list of unifiable goals if some goals are unifiable (see {!shelve_unifiable}) in the current focus. *) let guard_no_unifiable = let open Proof in Pv.get >>= fun initial -> let (u,n) = partition_unifiable initial.solution initial.comb in match u with - | [] -> tclUNIT () + | [] -> tclUNIT None | gls -> let l = CList.map (fun g -> Evd.dependent_evar_ident g initial.solution) gls in let l = CList.map (fun id -> Names.Name id) l in - tclZERO (Logic.RefinerError (Logic.UnresolvedBindings l)) + tclUNIT (Some l) (** [unshelve l p] adds all the goals in [l] at the end of the focused goals of p *) diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 61014468b5..20f67f2584 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -295,9 +295,9 @@ val shelve : unit tactic considered). *) val shelve_unifiable : unit tactic -(** [guard_no_unifiable] fails with error [UnresolvedBindings] if some +(** [guard_no_unifiable] returns the list of unifiable goals if some goals are unifiable (see {!shelve_unifiable}) in the current focus. *) -val guard_no_unifiable : unit tactic +val guard_no_unifiable : Names.Name.t list option tactic (** [unshelve l p] adds all the goals in [l] at the end of the focused goals of p *) -- cgit v1.2.3 From 93a77f3cb8ee36072f93b4c0ace6f0f9c19f51a3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 18:41:37 +0100 Subject: Moving Refine to its proper module. --- proofs/proof.ml | 28 ++++++------ proofs/proofs.mllib | 1 + proofs/proofview.ml | 117 +----------------------------------------------- proofs/proofview.mli | 41 +++-------------- proofs/refine.ml | 122 +++++++++++++++++++++++++++++++++++++++++++++++++++ proofs/refine.mli | 37 ++++++++++++++++ 6 files changed, 184 insertions(+), 162 deletions(-) create mode 100644 proofs/refine.ml create mode 100644 proofs/refine.mli (limited to 'proofs') diff --git a/proofs/proof.ml b/proofs/proof.ml index b604fde4eb..86af420dc4 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -334,22 +334,24 @@ let compact p = (*** Tactics ***) let run_tactic env tac pr = + let open Proofview.Notations in let sp = pr.proofview in - let (_,tacticced_proofview,(status,to_shelve,give_up),info_trace) = - Proofview.apply env tac sp + let undef sigma l = List.filter (fun g -> Evd.is_undefined sigma g) l in + let tac = + tac >>= fun () -> + Proofview.tclEVARMAP >>= fun sigma -> + (* Already solved goals are not to be counted as shelved. Nor are + they to be marked as unresolvable. *) + let retrieved = undef sigma (List.rev (Evd.future_goals sigma)) in + let sigma = List.fold_left Proofview.Unsafe.mark_as_goal sigma retrieved in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.tclUNIT retrieved in - let sigma = Proofview.return tacticced_proofview in - (* Already solved goals are not to be counted as shelved. Nor are - they to be marked as unresolvable. *) - let undef l = List.filter (fun g -> Evd.is_undefined sigma g) l in - let retrieved = undef (List.rev (Evd.future_goals sigma)) in - let shelf = (undef pr.shelf)@retrieved@(undef to_shelve) in - let proofview = - List.fold_left - Proofview.Unsafe.mark_as_goal - tacticced_proofview - retrieved + let (retrieved,proofview,(status,to_shelve,give_up),info_trace) = + Proofview.apply env tac sp in + let sigma = Proofview.return proofview in + let shelf = (undef sigma pr.shelf)@retrieved@(undef sigma to_shelve) in let given_up = pr.given_up@give_up in let proofview = Proofview.Unsafe.reset_future_goals proofview in { pr with proofview ; shelf ; given_up },(status,info_trace) diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 08556d62ec..236d479320 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -5,6 +5,7 @@ Proof_using Proof_errors Logic Proofview +Refine Proof Proof_global Redexpr diff --git a/proofs/proofview.ml b/proofs/proofview.ml index f42a60d9db..20be02e76d 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -901,7 +901,7 @@ module Unsafe = struct let reset_future_goals p = { p with solution = Evd.reset_future_goals p.solution } - let mark_as_goal_evm evd content = + let mark_as_goal evd content = let info = Evd.find evd content in let info = { info with Evd.evar_source = match info.Evd.evar_source with @@ -911,8 +911,7 @@ module Unsafe = struct let info = Typeclasses.mark_unresolvable info in Evd.add evd content info - let mark_as_goal p gl = - { p with solution = mark_as_goal_evm p.solution gl } + let advance = advance end @@ -1075,118 +1074,6 @@ end -(** {6 The refine tactic} *) - -module Refine = -struct - - let extract_prefix env info = - let ctx1 = List.rev (Environ.named_context env) in - let ctx2 = List.rev (Evd.evar_context info) in - let rec share l1 l2 accu = match l1, l2 with - | d1 :: l1, d2 :: l2 -> - if d1 == d2 then share l1 l2 (d1 :: accu) - else (accu, d2 :: l2) - | _ -> (accu, l2) - in - share ctx1 ctx2 [] - - let typecheck_evar ev env sigma = - let info = Evd.find sigma ev in - (** Typecheck the hypotheses. *) - let type_hyp (sigma, env) decl = - let t = get_type decl in - let evdref = ref sigma in - let _ = Typing.e_sort_of env evdref t in - let () = match decl with - | LocalAssum _ -> () - | LocalDef (_,body,_) -> Typing.e_check env evdref body t - in - (!evdref, Environ.push_named decl env) - in - let (common, changed) = extract_prefix env info in - let env = Environ.reset_with_named_context (Environ.val_of_named_context common) env in - let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in - (** Typecheck the conclusion *) - let evdref = ref sigma in - let _ = Typing.e_sort_of env evdref (Evd.evar_concl info) in - !evdref - - let typecheck_proof c concl env sigma = - let evdref = ref sigma in - let () = Typing.e_check env evdref c concl in - !evdref - - let (pr_constrv,pr_constr) = - Hook.make ~default:(fun _env _sigma _c -> Pp.str"") () - - let refine ?(unsafe = true) f = Goal.enter { Goal.enter = begin fun gl -> - let sigma = Goal.sigma gl in - let sigma = Sigma.to_evar_map sigma in - let env = Goal.env gl in - let concl = Goal.concl gl in - (** Save the [future_goals] state to restore them after the - refinement. *) - let prev_future_goals = Evd.future_goals sigma in - let prev_principal_goal = Evd.principal_future_goal sigma in - (** Create the refinement term *) - let (c, sigma) = Sigma.run (Evd.reset_future_goals sigma) f in - let evs = Evd.future_goals sigma in - let evkmain = Evd.principal_future_goal sigma in - (** Check that the introduced evars are well-typed *) - let fold accu ev = typecheck_evar ev env accu in - let sigma = if unsafe then sigma else CList.fold_left fold sigma evs in - (** Check that the refined term is typesafe *) - let sigma = if unsafe then sigma else typecheck_proof c concl env sigma in - (** Check that the goal itself does not appear in the refined term *) - let _ = - if not (Evarutil.occur_evar_upto sigma gl.Goal.self c) then () - else Pretype_errors.error_occur_check env sigma gl.Goal.self c - in - (** Proceed to the refinement *) - let sigma = match evkmain with - | None -> Evd.define gl.Goal.self c sigma - | Some evk -> - let id = Evd.evar_ident gl.Goal.self sigma in - let sigma = Evd.define gl.Goal.self c sigma in - match id with - | None -> sigma - | Some id -> Evd.rename evk id sigma - in - (** Restore the [future goals] state. *) - let sigma = Evd.restore_future_goals sigma prev_future_goals prev_principal_goal in - (** Select the goals *) - let comb = undefined sigma (CList.rev evs) in - let sigma = CList.fold_left Unsafe.mark_as_goal_evm sigma comb in - let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"refine"++spc()++ Hook.get pr_constrv env sigma c)))) >> - Pv.modify (fun ps -> { ps with solution = sigma; comb; }) - end } - - (** Useful definitions *) - - let with_type env evd c t = - let my_type = Retyping.get_type_of env evd c in - let j = Environ.make_judge c my_type in - let (evd,j') = - Coercion.inh_conv_coerce_to true (Loc.ghost) env evd j t - in - evd , j'.Environ.uj_val - - let refine_casted ?unsafe f = Goal.enter { Goal.enter = begin fun gl -> - let concl = Goal.concl gl in - let env = Goal.env gl in - let f = { run = fun h -> - let Sigma (c, h, p) = f.run h in - let sigma, c = with_type env (Sigma.to_evar_map h) c concl in - Sigma (c, Sigma.Unsafe.of_evar_map sigma, p) - } in - refine ?unsafe f - end } -end - - - (** {6 Trace} *) module Trace = struct diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 20f67f2584..6bc2e9a0ed 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -406,7 +406,13 @@ module Unsafe : sig (** Give an evar the status of a goal (changes its source location and makes it unresolvable for type classes. *) - val mark_as_goal : proofview -> Evar.t -> proofview + val mark_as_goal : Evd.evar_map -> Evar.t -> Evd.evar_map + + (** [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. *) + val advance : Evd.evar_map -> Evar.t -> Evar.t option end (** This module gives access to the innards of the monad. Its use is @@ -491,39 +497,6 @@ module Goal : sig end -(** {6 The refine tactic} *) - -module Refine : sig - - (** Printer used to print the constr which refine refines. *) - val pr_constr : - (Environ.env -> Evd.evar_map -> Term.constr -> Pp.std_ppcmds) Hook.t - - (** {7 Refinement primitives} *) - - val refine : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic - (** In [refine ?unsafe t], [t] is a term with holes under some - [evar_map] context. The term [t] is used as a partial solution - for the current goal (refine is a goal-dependent tactic), the - new holes created by [t] become the new subgoals. Exceptions - raised during the interpretation of [t] are caught and result in - tactic failures. If [unsafe] is [false] (default is [true]) [t] is - type-checked beforehand. *) - - (** {7 Helper functions} *) - - val with_type : Environ.env -> Evd.evar_map -> - Term.constr -> Term.types -> Evd.evar_map * Term.constr - (** [with_type env sigma c t] ensures that [c] is of type [t] - inserting a coercion if needed. *) - - val refine_casted : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic - (** Like {!refine} except the refined term is coerced to the conclusion of the - current goal. *) - -end - - (** {6 Trace} *) module Trace : sig diff --git a/proofs/refine.ml b/proofs/refine.ml new file mode 100644 index 0000000000..db0b26f7e5 --- /dev/null +++ b/proofs/refine.ml @@ -0,0 +1,122 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + if d1 == d2 then share l1 l2 (d1 :: accu) + else (accu, d2 :: l2) + | _ -> (accu, l2) + in + share ctx1 ctx2 [] + +let typecheck_evar ev env sigma = + let info = Evd.find sigma ev in + (** Typecheck the hypotheses. *) + let type_hyp (sigma, env) decl = + let t = get_type decl in + let evdref = ref sigma in + let _ = Typing.e_sort_of env evdref t in + let () = match decl with + | LocalAssum _ -> () + | LocalDef (_,body,_) -> Typing.e_check env evdref body t + in + (!evdref, Environ.push_named decl env) + in + let (common, changed) = extract_prefix env info in + let env = Environ.reset_with_named_context (Environ.val_of_named_context common) env in + let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in + (** Typecheck the conclusion *) + let evdref = ref sigma in + let _ = Typing.e_sort_of env evdref (Evd.evar_concl info) in + !evdref + +let typecheck_proof c concl env sigma = + let evdref = ref sigma in + let () = Typing.e_check env evdref c concl in + !evdref + +let (pr_constrv,pr_constr) = + Hook.make ~default:(fun _env _sigma _c -> Pp.str"") () + +let refine ?(unsafe = true) f = Proofview.Goal.enter { enter = begin fun gl -> + let gl = Proofview.Goal.assume gl in + let sigma = Proofview.Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in + (** Save the [future_goals] state to restore them after the + refinement. *) + let prev_future_goals = Evd.future_goals sigma in + let prev_principal_goal = Evd.principal_future_goal sigma in + (** Create the refinement term *) + let (c, sigma) = Sigma.run (Evd.reset_future_goals sigma) f in + let evs = Evd.future_goals sigma in + let evkmain = Evd.principal_future_goal sigma in + (** Check that the introduced evars are well-typed *) + let fold accu ev = typecheck_evar ev env accu in + let sigma = if unsafe then sigma else CList.fold_left fold sigma evs in + (** Check that the refined term is typesafe *) + let sigma = if unsafe then sigma else typecheck_proof c concl env sigma in + (** Check that the goal itself does not appear in the refined term *) + let self = Proofview.Goal.goal gl in + let _ = + if not (Evarutil.occur_evar_upto sigma self c) then () + else Pretype_errors.error_occur_check env sigma self c + in + (** Proceed to the refinement *) + let sigma = match evkmain with + | None -> Evd.define self c sigma + | Some evk -> + let id = Evd.evar_ident self sigma in + let sigma = Evd.define self c sigma in + match id with + | None -> sigma + | Some id -> Evd.rename evk id sigma + in + (** Restore the [future goals] state. *) + let sigma = Evd.restore_future_goals sigma prev_future_goals prev_principal_goal in + (** Select the goals *) + let comb = CList.map_filter (Proofview.Unsafe.advance sigma) (CList.rev evs) in + let sigma = CList.fold_left Proofview.Unsafe.mark_as_goal sigma comb in + let trace () = Pp.(hov 2 (str"refine"++spc()++ Hook.get pr_constrv env sigma c)) in + Proofview.Trace.name_tactic trace (Proofview.tclUNIT ()) >>= fun () -> + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.Unsafe.tclSETGOALS comb +end } + +(** Useful definitions *) + +let with_type env evd c t = + let my_type = Retyping.get_type_of env evd c in + let j = Environ.make_judge c my_type in + let (evd,j') = + Coercion.inh_conv_coerce_to true (Loc.ghost) env evd j t + in + evd , j'.Environ.uj_val + +let refine_casted ?unsafe f = Proofview.Goal.enter { enter = begin fun gl -> + let gl = Proofview.Goal.assume gl in + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let f = { run = fun h -> + let Sigma (c, h, p) = f.run h in + let sigma, c = with_type env (Sigma.to_evar_map h) c concl in + Sigma (c, Sigma.Unsafe.of_evar_map sigma, p) + } in + refine ?unsafe f +end } diff --git a/proofs/refine.mli b/proofs/refine.mli new file mode 100644 index 0000000000..17c7e28ca9 --- /dev/null +++ b/proofs/refine.mli @@ -0,0 +1,37 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Evd.evar_map -> Term.constr -> Pp.std_ppcmds) Hook.t + +(** {7 Refinement primitives} *) + +val refine : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic +(** In [refine ?unsafe t], [t] is a term with holes under some + [evar_map] context. The term [t] is used as a partial solution + for the current goal (refine is a goal-dependent tactic), the + new holes created by [t] become the new subgoals. Exceptions + raised during the interpretation of [t] are caught and result in + tactic failures. If [unsafe] is [false] (default is [true]) [t] is + type-checked beforehand. *) + +(** {7 Helper functions} *) + +val with_type : Environ.env -> Evd.evar_map -> + Term.constr -> Term.types -> Evd.evar_map * Term.constr +(** [with_type env sigma c t] ensures that [c] is of type [t] + inserting a coercion if needed. *) + +val refine_casted : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic +(** Like {!refine} except the refined term is coerced to the conclusion of the + current goal. *) -- cgit v1.2.3 From ea4e09c26747fa9c49882580a72139fe748a0d64 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 19:38:36 +0100 Subject: Moving Proofview to pretyping/. --- proofs/proofs.mllib | 1 - proofs/proofview.ml | 1204 -------------------------------------------------- proofs/proofview.mli | 586 ------------------------ 3 files changed, 1791 deletions(-) delete mode 100644 proofs/proofview.ml delete mode 100644 proofs/proofview.mli (limited to 'proofs') diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 236d479320..9130a186ba 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -4,7 +4,6 @@ Evar_refiner Proof_using Proof_errors Logic -Proofview Refine Proof Proof_global diff --git a/proofs/proofview.ml b/proofs/proofview.ml deleted file mode 100644 index 20be02e76d..0000000000 --- a/proofs/proofview.ml +++ /dev/null @@ -1,1204 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* i+1) solution 0 in - let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in - let pruned_solution = Evd.drop_all_defined solution in - let apply_subst_einfo _ ei = - Evd.({ ei with - evar_concl = nf ei.evar_concl; - evar_hyps = Environ.map_named_val nf ei.evar_hyps; - evar_candidates = Option.map (List.map nf) ei.evar_candidates }) in - let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in - let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in - msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size)); - new_el, { pv with solution = new_solution; } - - -(** {6 Starting and querying a proof view} *) - -type telescope = - | TNil of Evd.evar_map - | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope) - -let dependent_init = - (* Goals are created with a store which marks them as unresolvable - for type classes. *) - let store = Typeclasses.set_resolvable Evd.Store.empty false in - (* Goals don't have a source location. *) - let src = (Loc.ghost,Evar_kinds.GoalEvar) in - (* Main routine *) - let rec aux = function - | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] } - | TCons (env, sigma, typ, t) -> - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (econstr, sigma, _) = Evarutil.new_evar env sigma ~src ~store typ in - let sigma = Sigma.to_evar_map sigma in - let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in - let (gl, _) = Term.destEvar econstr in - let entry = (econstr, typ) :: ret in - entry, { solution = sol; comb = gl :: comb; shelf = [] } - in - fun t -> - let entry, v = aux t in - (* The created goal are not to be shelved. *) - let solution = Evd.reset_future_goals v.solution in - entry, { v with solution } - -let init = - let rec aux sigma = function - | [] -> TNil sigma - | (env,g)::l -> TCons (env,sigma,g,(fun sigma _ -> aux sigma l)) - in - fun sigma l -> dependent_init (aux sigma l) - -let initial_goals initial = initial - -let finished = function - | {comb = []} -> true - | _ -> false - -let return { solution=defs } = defs - -let return_constr { solution = defs } c = Evarutil.nf_evar defs c - -let partial_proof entry pv = CList.map (return_constr pv) (CList.map fst entry) - - -(** {6 Focusing commands} *) - -(** A [focus_context] represents the part of the proof view which has - been removed by a focusing action, it can be used to unfocus later - on. *) -(* First component is a reverse list of the goals which come before - and second component is the list of the goals which go after (in - the expected order). *) -type focus_context = Evar.t list * Evar.t list - - -(** Returns a stylised view of a focus_context for use by, for - instance, ide-s. *) -(* spiwack: the type of [focus_context] will change as we push more - refined functions to ide-s. This would be better than spawning a - new nearly identical function everytime. Hence the generic name. *) -(* In this version: the goals in the context, as a "zipper" (the first - list is in reversed order). *) -let focus_context f = f - -(** 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) = CList.goto (i-1) l in - let (sub, right) = - try CList.chop (j-i+1) sub_right - with Failure _ -> raise CList.IndexOutOfRange - in - (sub, (left,right)) - -(** Inverse operation to the previous one. *) -let unfocus_sublist (left,right) s = - CList.rev_append left (s@right) - - -(** [focus i j] focuses a proofview on the goals from index [i] to - index [j] (inclusive, goals are indexed from [1]). I.e. goals - number [i] to [j] become the only focused goals of the returned - proofview. It returns the focused proofview, and a context for - the focus stack. *) -let focus i j sp = - let (new_comb, context) = focus_sublist i j sp.comb in - ( { sp with comb = new_comb } , context ) - - -(** [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. *) -(* spiwack: [advance] is probably performance critical, and the good - behaviour of its definition may depend sensitively to the actual - definition of [Evd.find]. Currently, [Evd.find] starts looking for - a value in the heap of undefined variable, which is small. Hence in - the most common case, where [advance] is applied to an unsolved - goal ([advance] is used to figure if a side effect has modified the - goal) it terminates quickly. *) -let rec advance sigma g = - let open Evd in - let evi = Evd.find sigma g in - match evi.evar_body with - | Evar_empty -> Some g - | Evar_defined v -> - if Option.default false (Store.get evi.evar_extra Evarutil.cleared) then - let (e,_) = Term.destEvar v in - advance sigma e - else - None - -(** [undefined defs l] is the list of goals in [l] which are still - unsolved (after advancing cleared goals). *) -let undefined defs l = CList.map_filter (advance defs) l - -(** Unfocuses a proofview with respect to a context. *) -let unfocus c sp = - { sp with comb = undefined sp.solution (unfocus_sublist c sp.comb) } - - -(** {6 The tactic monad} *) - -(** - Tactics are objects which apply a transformation to all the - subgoals of the current view at the same time. By opposition to - the old vision of applying it to a single goal. It allows tactics - such as [shelve_unifiable], tactics to reorder the focused goals, - 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). Another benefit is that it is possible to write tactics - that can be executed even if there are no focused goals. - - Tactics form a monad ['a tactic], in a sense a tactic can be - seen as a function (without argument) which returns a value of - type 'a and modifies the environment (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 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") and [Proofview.tclTHEN] - (which is a specialized bind on unit-returning tactics). - - Tactics have support for full-backtracking. Tactics can be seen - having multiple success: if after returning the first success a - failure is encountered, the tactic can backtrack and use a second - success if available. The state is backtracked to its previous - value, except the non-logical state defined in the {!NonLogical} - module below. -*) -(* spiwack: as far as I'm aware this doesn't really relate to - F. Kirchner and C. Muñoz. *) - -module Proof = Logical - -(** type of tactics: - - tactics can - - access the environment, - - report unsafe status, shelved goals and given up goals - - access and change the current [proofview] - - backtrack on previous changes of the proofview *) -type +'a tactic = 'a Proof.t - -(** Applies a tactic to the current proofview. *) -let apply env t sp = - let open Logic_monad in - let ans = Proof.repr (Proof.run t false (sp,env)) in - let ans = Logic_monad.NonLogical.run ans in - match ans with - | Nil (e, info) -> iraise (TacticFailure e, info) - | Cons ((r, (state, _), status, info), _) -> - let (status, gaveup) = status in - let status = (status, state.shelf, gaveup) in - let state = { state with shelf = [] } in - r, state, status, Trace.to_tree info - - - -(** {7 Monadic primitives} *) - -(** Unit of the tactic monad. *) -let tclUNIT = Proof.return - -(** Bind operation of the tactic monad. *) -let tclBIND = Proof.(>>=) - -(** Interpretes the ";" (semicolon) of Ltac. As a monadic operation, - it's a specialized "bind". *) -let tclTHEN = Proof.(>>) - -(** [tclIGNORE t] has the same operational content as [t], but drops - the returned value. *) -let tclIGNORE = Proof.ignore - -module Monad = Proof - - - -(** {7 Failure and backtracking} *) - - -(** [tclZERO e] fails with exception [e]. It has no success. *) -let tclZERO ?info e = - let info = match info with - | None -> Exninfo.null - | Some info -> info - in - Proof.zero (e, info) - -(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever - the successes of [t1] have been depleted and it failed with [e], - then it behaves as [t2 e]. In other words, [tclOR] inserts a - backtracking point. *) -let tclOR = Proof.plus - -(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one - success or [t2 e] if [t1] fails with [e]. It is analogous to - [try/with] handler of exception in that it is not a backtracking - point. *) -let tclORELSE t1 t2 = - let open Logic_monad in - let open Proof in - split t1 >>= function - | Nil e -> t2 e - | Cons (a,t1') -> plus (return a) t1' - -(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a] - succeeds at least once then it behaves as [tclBIND a s] otherwise, - if [a] fails with [e], then it behaves as [f e]. *) -let tclIFCATCH a s f = - let open Logic_monad in - let open Proof in - split a >>= function - | Nil e -> f e - | Cons (x,a') -> plus (s x) (fun e -> (a' e) >>= fun x' -> (s x')) - -(** [tclONCE t] behave like [t] except it has at most one success: - [tclONCE t] stops after the first success of [t]. If [t] fails - with [e], [tclONCE t] also fails with [e]. *) -let tclONCE = Proof.once - -exception MoreThanOneSuccess -let _ = Errors.register_handler begin function - | MoreThanOneSuccess -> Errors.error "This tactic has more than one success." - | _ -> raise Errors.Unhandled -end - -(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one - success. Otherwise it fails. The tactic [t] is run until its first - success, then a failure with exception [e] is simulated. It [t] - yields another success, then [tclEXACTLY_ONCE e t] fails with - [MoreThanOneSuccess] (it is a user error). Otherwise, - [tclEXACTLY_ONCE e t] succeeds with the first success of - [t]. Notice that the choice of [e] is relevant, as the presence of - further successes may depend on [e] (see {!tclOR}). *) -let tclEXACTLY_ONCE e t = - let open Logic_monad in - let open Proof in - split t >>= function - | Nil (e, info) -> tclZERO ~info e - | Cons (x,k) -> - Proof.split (k (e, Exninfo.null)) >>= function - | Nil _ -> tclUNIT x - | _ -> tclZERO MoreThanOneSuccess - - -(** [tclCASE t] wraps the {!Proofview_monad.Logical.split} primitive. *) -type 'a case = -| Fail of iexn -| Next of 'a * (iexn -> 'a tactic) -let tclCASE t = - let open Logic_monad in - let map = function - | Nil e -> Fail e - | Cons (x, t) -> Next (x, t) - in - Proof.map map (Proof.split t) - -let tclBREAK = Proof.break - - - -(** {7 Focusing tactics} *) - -exception NoSuchGoals of int - -(* This hook returns a string to be appended to the usual message. - Primarily used to add a suggestion about the right bullet to use to - focus the next goal, if applicable. *) -let nosuchgoals_hook:(int -> std_ppcmds) ref = ref (fun n -> mt ()) -let set_nosuchgoals_hook f = nosuchgoals_hook := f - - - -(* This uses the hook above *) -let _ = Errors.register_handler begin function - | NoSuchGoals n -> - let suffix = !nosuchgoals_hook n in - Errors.errorlabstrm "" - (str "No such " ++ str (String.plural n "goal") ++ str "." ++ suffix) - | _ -> raise Errors.Unhandled -end - -(** [tclFOCUS_gen nosuchgoal i j t] applies [t] in a context where - only the goals numbered [i] to [j] are focused (the rest of the goals - is restored at the end of the tactic). If the range [i]-[j] is not - valid, then it [tclFOCUS_gen nosuchgoal i j t] is [nosuchgoal]. *) -let tclFOCUS_gen nosuchgoal i j t = - let open Proof in - Pv.get >>= fun initial -> - try - let (focused,context) = focus i j initial in - Pv.set focused >> - t >>= fun result -> - Pv.modify (fun next -> unfocus context next) >> - return result - with CList.IndexOutOfRange -> nosuchgoal - -let tclFOCUS i j t = tclFOCUS_gen (tclZERO (NoSuchGoals (j+1-i))) i j t -let tclTRYFOCUS i j t = tclFOCUS_gen (tclUNIT ()) i j t - -(** Like {!tclFOCUS} but selects a single goal by name. *) -let tclFOCUSID id t = - let open Proof in - Pv.get >>= fun initial -> - try - let ev = Evd.evar_key id initial.solution in - try - let n = CList.index Evar.equal ev initial.comb in - (* goal is already under focus *) - let (focused,context) = focus n n initial in - Pv.set focused >> - t >>= fun result -> - Pv.modify (fun next -> unfocus context next) >> - return result - with Not_found -> - (* otherwise, save current focus and work purely on the shelve *) - Comb.set [ev] >> - t >>= fun result -> - Comb.set initial.comb >> - return result - with Not_found -> tclZERO (NoSuchGoals 1) - -(** {7 Dispatching on goals} *) - -exception SizeMismatch of int*int -let _ = Errors.register_handler begin function - | SizeMismatch (i,_) -> - let open Pp in - let errmsg = - str"Incorrect number of goals" ++ spc() ++ - str"(expected "++int i++str(String.plural i " tactic") ++ str")." - in - Errors.errorlabstrm "" errmsg - | _ -> raise Errors.Unhandled -end - -(** A variant of [Monad.List.iter] where we iter over the focused list - of goals. The argument tactic is executed in a focus comprising - only of the current goal, a goal which has been solved by side - effect is skipped. The generated subgoals are concatenated in - order. *) -let iter_goal i = - let open Proof in - Comb.get >>= fun initial -> - Proof.List.fold_left begin fun (subgoals as cur) goal -> - Solution.get >>= fun step -> - match advance step goal with - | None -> return cur - | Some goal -> - Comb.set [goal] >> - i goal >> - Proof.map (fun comb -> comb :: subgoals) Comb.get - end [] initial >>= fun subgoals -> - Solution.get >>= fun evd -> - Comb.set CList.(undefined evd (flatten (rev subgoals))) - -(** A variant of [Monad.List.fold_left2] where the first list is the - list of focused goals. The argument tactic is executed in a focus - comprising only of the current goal, a goal which has been solved - by side effect is skipped. The generated subgoals are concatenated - in order. *) -let fold_left2_goal i s l = - let open Proof in - Pv.get >>= fun initial -> - let err = - return () >>= fun () -> (* Delay the computation of list lengths. *) - tclZERO (SizeMismatch (CList.length initial.comb,CList.length l)) - in - Proof.List.fold_left2 err begin fun ((r,subgoals) as cur) goal a -> - Solution.get >>= fun step -> - match advance step goal with - | None -> return cur - | Some goal -> - Comb.set [goal] >> - i goal a r >>= fun r -> - Proof.map (fun comb -> (r, comb :: subgoals)) Comb.get - end (s,[]) initial.comb l >>= fun (r,subgoals) -> - Solution.get >>= fun evd -> - Comb.set CList.(undefined evd (flatten (rev subgoals))) >> - return r - -(** Dispatch tacticals are used to apply a different tactic to each - goal under focus. They come in two flavours: [tclDISPATCH] takes a - list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL] - takes a list of ['a tactic] and returns an ['a list tactic]. - - They both work by applying each of the tactic in a focus - restricted to the corresponding goal (starting with the first - goal). In the case of [tclDISPATCHL], the tactic returns a list of - the same size as the argument list (of tactics), each element - being the result of the tactic executed in the corresponding goal. - - When the length of the tactic list is not the number of goal, - raises [SizeMismatch (g,t)] where [g] is the number of available - goals, and [t] the number of tactics passed. - - [tclDISPATCHGEN join tacs] generalises both functions as the - successive results of [tacs] are stored in reverse order in a - list, and [join] is used to convert the result into the expected - form. *) -let tclDISPATCHGEN0 join tacs = - match tacs with - | [] -> - begin - let open Proof in - Comb.get >>= function - | [] -> tclUNIT (join []) - | comb -> tclZERO (SizeMismatch (CList.length comb,0)) - end - | [tac] -> - begin - let open Proof in - Pv.get >>= function - | { comb=[goal] ; solution } -> - begin match advance solution goal with - | None -> tclUNIT (join []) - | Some _ -> Proof.map (fun res -> join [res]) tac - end - | {comb} -> tclZERO (SizeMismatch(CList.length comb,1)) - end - | _ -> - let iter _ t cur = Proof.map (fun y -> y :: cur) t in - let ans = fold_left2_goal iter [] tacs in - Proof.map join ans - -let tclDISPATCHGEN join tacs = - let branch t = InfoL.tag (Info.DBranch) t in - let tacs = CList.map branch tacs in - InfoL.tag (Info.Dispatch) (tclDISPATCHGEN0 join tacs) - -let tclDISPATCH tacs = tclDISPATCHGEN Pervasives.ignore tacs - -let tclDISPATCHL tacs = tclDISPATCHGEN CList.rev tacs - - -(** [extend_to_list startxs rx endxs l] builds a list - [startxs@[rx,...,rx]@endxs] of the same length as [l]. Raises - [SizeMismatch] if [startxs@endxs] is already longer than [l]. *) -let extend_to_list startxs rx endxs l = - (* spiwack: I use [l] essentially as a natural number *) - let rec duplicate acc = function - | [] -> acc - | _::rest -> duplicate (rx::acc) rest - in - let rec tail to_match rest = - match rest, to_match with - | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *) - | _::rest , _::to_match -> tail to_match rest - | _ , [] -> duplicate endxs rest - in - let rec copy pref rest = - match rest,pref with - | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *) - | _::rest, a::pref -> a::(copy pref rest) - | _ , [] -> tail endxs rest - in - copy startxs l - -(** [tclEXTEND b r e] is a variant of {!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). *) -let tclEXTEND tacs1 rtac tacs2 = - let open Proof in - Comb.get >>= fun comb -> - try - let tacs = extend_to_list tacs1 rtac tacs2 comb in - tclDISPATCH tacs - with SizeMismatch _ -> - tclZERO (SizeMismatch( - CList.length comb, - (CList.length tacs1)+(CList.length tacs2))) -(* spiwack: failure occurs only when the number of goals is too - small. Hence we can assume that [rtac] is replicated 0 times for - any error message. *) - -(** [tclEXTEND [] tac []]. *) -let tclINDEPENDENT tac = - let open Proof in - Pv.get >>= fun initial -> - match initial.comb with - | [] -> tclUNIT () - | [_] -> tac - | _ -> - let tac = InfoL.tag (Info.DBranch) tac in - InfoL.tag (Info.Dispatch) (iter_goal (fun _ -> tac)) - - - -(** {7 Goal manipulation} *) - -(** Shelves all the goals under focus. *) -let shelve = - let open Proof in - Comb.get >>= fun initial -> - Comb.set [] >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >> - Shelf.modify (fun gls -> gls @ initial) - - -(** [contained_in_info e evi] checks whether the evar [e] appears in - the hypotheses, the conclusion or the body of the evar_info - [evi]. Note: since we want to use it on goals, the body is actually - supposed to be empty. *) -let contained_in_info sigma e evi = - Evar.Set.mem e (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi)) - -(** [depends_on sigma src tgt] checks whether the goal [src] appears - as an existential variable in the definition of the goal [tgt] in - [sigma]. *) -let depends_on sigma src tgt = - let evi = Evd.find sigma tgt in - contained_in_info sigma src evi - -(** [unifiable sigma g l] checks whether [g] appears in another - subgoal of [l]. The list [l] may contain [g], but it does not - affect the result. *) -let unifiable sigma g l = - CList.exists (fun tgt -> not (Evar.equal g tgt) && depends_on sigma g tgt) l - -(** [partition_unifiable sigma l] partitions [l] into a pair [(u,n)] - where [u] is composed of the unifiable goals, i.e. the goals on - whose definition other goals of [l] depend, and [n] are the - non-unifiable goals. *) -let partition_unifiable sigma l = - CList.partition (fun g -> unifiable sigma g l) l - -(** Shelves the unifiable goals under focus, i.e. the goals which - appear in other goals under focus (the unfocused goals are not - considered). *) -let shelve_unifiable = - let open Proof in - Pv.get >>= fun initial -> - let (u,n) = partition_unifiable initial.solution initial.comb in - Comb.set n >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >> - Shelf.modify (fun gls -> gls @ u) - -(** [guard_no_unifiable] returns the list of unifiable goals if some - goals are unifiable (see {!shelve_unifiable}) in the current focus. *) -let guard_no_unifiable = - let open Proof in - Pv.get >>= fun initial -> - let (u,n) = partition_unifiable initial.solution initial.comb in - match u with - | [] -> tclUNIT None - | gls -> - let l = CList.map (fun g -> Evd.dependent_evar_ident g initial.solution) gls in - let l = CList.map (fun id -> Names.Name id) l in - tclUNIT (Some l) - -(** [unshelve l p] adds all the goals in [l] at the end of the focused - goals of p *) -let unshelve l p = - (* advance the goals in case of clear *) - let l = undefined p.solution l in - { p with comb = p.comb@l } - -let with_shelf tac = - let open Proof in - Pv.get >>= fun pv -> - let { shelf; solution } = pv in - Pv.set { pv with shelf = []; solution = Evd.reset_future_goals solution } >> - tac >>= fun ans -> - Pv.get >>= fun npv -> - let { shelf = gls; solution = sigma } = npv in - let gls' = Evd.future_goals sigma in - let fgoals = Evd.future_goals solution in - let pgoal = Evd.principal_future_goal solution in - let sigma = Evd.restore_future_goals sigma fgoals pgoal in - Pv.set { npv with shelf; solution = sigma } >> - tclUNIT (CList.rev_append gls' gls, ans) - -(** [goodmod p m] computes the representative of [p] modulo [m] in the - interval [[0,m-1]].*) -let goodmod p m = - let p' = p mod m in - (* if [n] is negative [n mod l] is negative of absolute value less - than [l], so [(n mod l)+l] is the representative of [n] in the - interval [[0,l-1]].*) - if p' < 0 then p'+m else p' - -let cycle n = - let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(str"cycle "++int n))) >> - Comb.modify begin fun initial -> - let l = CList.length initial in - let n' = goodmod n l in - let (front,rear) = CList.chop n' initial in - rear@front - end - -let swap i j = - let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"swap"++spc()++int i++spc()++int j)))) >> - Comb.modify begin fun initial -> - let l = CList.length initial in - let i = if i>0 then i-1 else i and j = if j>0 then j-1 else j in - let i = goodmod i l and j = goodmod j l in - CList.map_i begin fun k x -> - match k with - | k when Int.equal k i -> CList.nth initial j - | k when Int.equal k j -> CList.nth initial i - | _ -> x - end 0 initial - end - -let revgoals = - let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.str"revgoals")) >> - Comb.modify CList.rev - -let numgoals = - let open Proof in - Comb.get >>= fun comb -> - return (CList.length comb) - - - -(** {7 Access primitives} *) - -let tclEVARMAP = Solution.get - -let tclENV = Env.get - - - -(** {7 Put-like primitives} *) - - -let emit_side_effects eff x = - { x with solution = Evd.emit_side_effects eff x.solution } - -let tclEFFECTS eff = - let open Proof in - return () >>= fun () -> (* The Global.env should be taken at exec time *) - Env.set (Global.env ()) >> - Pv.modify (fun initial -> emit_side_effects eff initial) - -let mark_as_unsafe = Status.put false - -(** Gives up on the goal under focus. Reports an unsafe status. Proofs - with given up goals cannot be closed. *) -let give_up = - let open Proof in - Comb.get >>= fun initial -> - Comb.set [] >> - mark_as_unsafe >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"give_up")) >> - Giveup.put initial - - - -(** {7 Control primitives} *) - - -module Progress = struct - - let eq_constr = Evarutil.eq_constr_univs_test - - (** equality function on hypothesis contexts *) - let eq_named_context_val sigma1 sigma2 ctx1 ctx2 = - let open Environ in - let c1 = named_context_of_val ctx1 and c2 = named_context_of_val ctx2 in - let eq_named_declaration d1 d2 = - match d1, d2 with - | LocalAssum (i1,t1), LocalAssum (i2,t2) -> - Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 t1 t2 - | LocalDef (i1,c1,t1), LocalDef (i2,c2,t2) -> - Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 c1 c2 - && eq_constr sigma1 sigma2 t1 t2 - | _ -> - false - in List.equal eq_named_declaration c1 c2 - - let eq_evar_body sigma1 sigma2 b1 b2 = - let open Evd in - match b1, b2 with - | Evar_empty, Evar_empty -> true - | Evar_defined t1, Evar_defined t2 -> eq_constr sigma1 sigma2 t1 t2 - | _ -> false - - let eq_evar_info sigma1 sigma2 ei1 ei2 = - let open Evd in - eq_constr sigma1 sigma2 ei1.evar_concl ei2.evar_concl && - eq_named_context_val sigma1 sigma2 (ei1.evar_hyps) (ei2.evar_hyps) && - eq_evar_body sigma1 sigma2 ei1.evar_body ei2.evar_body - - (** Equality function on goals *) - let goal_equal evars1 gl1 evars2 gl2 = - let evi1 = Evd.find evars1 gl1 in - let evi2 = Evd.find evars2 gl2 in - eq_evar_info evars1 evars2 evi1 evi2 - -end - -let tclPROGRESS t = - let open Proof in - Pv.get >>= fun initial -> - t >>= fun res -> - Pv.get >>= fun final -> - (* [*_test] test absence of progress. [quick_test] is approximate - whereas [exhaustive_test] is complete. *) - let quick_test = - initial.solution == final.solution && initial.comb == final.comb - in - let exhaustive_test = - Util.List.for_all2eq begin fun i f -> - Progress.goal_equal initial.solution i final.solution f - end initial.comb final.comb - in - let test = - quick_test || exhaustive_test - in - if not test then - tclUNIT res - else - tclZERO (Errors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress.")) - -exception Timeout -let _ = Errors.register_handler begin function - | Timeout -> Errors.errorlabstrm "Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") - | _ -> Pervasives.raise Errors.Unhandled -end - -let tclTIMEOUT n t = - let open Proof in - (* spiwack: as one of the monad is a continuation passing monad, it - doesn't force the computation to be threaded inside the underlying - (IO) monad. Hence I force it myself by asking for the evaluation of - a dummy value first, lest [timeout] be called when everything has - already been computed. *) - let t = Proof.lift (Logic_monad.NonLogical.return ()) >> t in - Proof.get >>= fun initial -> - Proof.current >>= fun envvar -> - Proof.lift begin - Logic_monad.NonLogical.catch - begin - let open Logic_monad.NonLogical in - timeout n (Proof.repr (Proof.run t envvar initial)) >>= fun r -> - match r with - | Logic_monad.Nil e -> return (Util.Inr e) - | Logic_monad.Cons (r, _) -> return (Util.Inl r) - end - begin let open Logic_monad.NonLogical in function (e, info) -> - match e with - | Logic_monad.Timeout -> return (Util.Inr (Timeout, info)) - | Logic_monad.TacticFailure e -> - return (Util.Inr (e, info)) - | e -> Logic_monad.NonLogical.raise ~info e - end - end >>= function - | Util.Inl (res,s,m,i) -> - Proof.set s >> - Proof.put m >> - Proof.update (fun _ -> i) >> - return res - | Util.Inr (e, info) -> tclZERO ~info e - -let tclTIME s t = - let pr_time t1 t2 n msg = - let msg = - if n = 0 then - str msg - else - str (msg ^ " after ") ++ int n ++ str (String.plural n " backtracking") - in - msg_info(str "Tactic call" ++ pr_opt str s ++ str " ran for " ++ - System.fmt_time_difference t1 t2 ++ str " " ++ surround msg) in - let rec aux n t = - let open Proof in - tclUNIT () >>= fun () -> - let tstart = System.get_time() in - Proof.split t >>= let open Logic_monad in function - | Nil (e, info) -> - begin - let tend = System.get_time() in - pr_time tstart tend n "failure"; - tclZERO ~info e - end - | Cons (x,k) -> - let tend = System.get_time() in - pr_time tstart tend n "success"; - tclOR (tclUNIT x) (fun e -> aux (n+1) (k e)) - in aux 0 t - - - -(** {7 Unsafe primitives} *) - -module Unsafe = struct - - let tclEVARS evd = - Pv.modify (fun ps -> { ps with solution = evd }) - - let tclNEWGOALS gls = - Pv.modify begin fun step -> - let gls = undefined step.solution gls in - { step with comb = step.comb @ gls } - end - - let tclGETGOALS = Comb.get - - let tclSETGOALS = Comb.set - - let tclEVARSADVANCE evd = - Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb }) - - let tclEVARUNIVCONTEXT ctx = - Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx }) - - let reset_future_goals p = - { p with solution = Evd.reset_future_goals p.solution } - - let mark_as_goal evd content = - let info = Evd.find evd content in - let info = - { info with Evd.evar_source = match info.Evd.evar_source with - | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x - | loc,_ -> loc,Evar_kinds.GoalEvar } - in - let info = Typeclasses.mark_unresolvable info in - Evd.add evd content info - - let advance = advance - -end - -module UnsafeRepr = Proof.Unsafe - -let (>>=) = tclBIND -let (<*>) = tclTHEN -let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) - -(** {6 Goal-dependent tactics} *) - -let goal_env evars gl = - let evi = Evd.find evars gl in - Evd.evar_filtered_env evi - -let goal_nf_evar sigma gl = - let evi = Evd.find sigma gl in - let evi = Evarutil.nf_evar_info sigma evi in - let sigma = Evd.add sigma gl evi in - (gl, sigma) - -let goal_extra evars gl = - let evi = Evd.find evars gl in - evi.Evd.evar_extra - - -let catchable_exception = function - | Logic_monad.Exception _ -> false - | e -> Errors.noncritical e - - -module Goal = struct - - type ('a, 'r) t = { - env : Environ.env; - sigma : Evd.evar_map; - concl : Term.constr ; - self : Evar.t ; (* for compatibility with old-style definitions *) - } - - type ('a, 'b) enter = - { enter : 'r. ('a, 'r) t -> 'b } - - let assume (gl : ('a, 'r) t) = (gl :> ([ `NF ], 'r) t) - - let env { env=env } = env - let sigma { sigma=sigma } = Sigma.Unsafe.of_evar_map sigma - let hyps { env=env } = Environ.named_context env - let concl { concl=concl } = concl - let extra { sigma=sigma; self=self } = goal_extra sigma self - - let raw_concl { concl=concl } = concl - - - let gmake_with info env sigma goal = - { env = Environ.reset_with_named_context (Evd.evar_filtered_hyps info) env ; - sigma = sigma ; - concl = Evd.evar_concl info ; - self = goal } - - let nf_gmake env sigma goal = - let info = Evarutil.nf_evar_info sigma (Evd.find sigma goal) in - let sigma = Evd.add sigma goal info in - gmake_with info env sigma goal , sigma - - let nf_enter f = - InfoL.tag (Info.Dispatch) begin - iter_goal begin fun goal -> - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - try - let (gl, sigma) = nf_gmake env sigma goal in - tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f.enter gl)) - with e when catchable_exception e -> - let (e, info) = Errors.push e in - tclZERO ~info e - end - end - - let normalize { self } = - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - let (gl,sigma) = nf_gmake env sigma self in - tclTHEN (Unsafe.tclEVARS sigma) (tclUNIT gl) - - let gmake env sigma goal = - let info = Evd.find sigma goal in - gmake_with info env sigma goal - - let enter f = - let f gl = InfoL.tag (Info.DBranch) (f.enter gl) in - InfoL.tag (Info.Dispatch) begin - iter_goal begin fun goal -> - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - try f (gmake env sigma goal) - with e when catchable_exception e -> - let (e, info) = Errors.push e in - tclZERO ~info e - end - end - - type ('a, 'b) s_enter = - { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } - - let s_enter f = - InfoL.tag (Info.Dispatch) begin - iter_goal begin fun goal -> - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - try - let gl = gmake env sigma goal in - let Sigma (tac, sigma, _) = f.s_enter gl in - let sigma = Sigma.to_evar_map sigma in - tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) - with e when catchable_exception e -> - let (e, info) = Errors.push e in - tclZERO ~info e - end - end - - let nf_s_enter f = - InfoL.tag (Info.Dispatch) begin - iter_goal begin fun goal -> - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - try - let (gl, sigma) = nf_gmake env sigma goal in - let Sigma (tac, sigma, _) = f.s_enter gl in - let sigma = Sigma.to_evar_map sigma in - tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) - with e when catchable_exception e -> - let (e, info) = Errors.push e in - tclZERO ~info e - end - end - - let goals = - Pv.get >>= fun step -> - let sigma = step.solution in - let map goal = - match advance sigma goal with - | None -> None (** ppedrot: Is this check really necessary? *) - | Some goal -> - let gl = - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - tclUNIT (gmake env sigma goal) - in - Some gl - in - tclUNIT (CList.map_filter map step.comb) - - (* compatibility *) - let goal { self=self } = self - - let lift (gl : ('a, 'r) t) _ = (gl :> ('a, 's) t) - -end - - - -(** {6 Trace} *) - -module Trace = struct - - let record_info_trace = InfoL.record_trace - - let log m = InfoL.leaf (Info.Msg m) - let name_tactic m t = InfoL.tag (Info.Tactic m) t - - let pr_info ?(lvl=0) info = - assert (lvl >= 0); - Info.(print (collapse lvl info)) - -end - - - -(** {6 Non-logical state} *) - -module NonLogical = Logic_monad.NonLogical - -let tclLIFT = Proof.lift - -let tclCHECKINTERRUPT = - tclLIFT (NonLogical.make Control.check_for_interrupt) - - - - - -(*** Compatibility layer with <= 8.2 tactics ***) -module V82 = struct - type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma - - let tactic tac = - (* spiwack: we ignore the dependencies between goals here, - expectingly preserving the semantics of <= 8.2 tactics *) - (* spiwack: convenience notations, waiting for ocaml 3.12 *) - let open Proof in - Pv.get >>= fun ps -> - try - let tac gl evd = - let glsigma = - tac { Evd.it = gl ; 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) = - Evd.Monad.List.map (fun g s -> goal_nf_evar s g) ps.comb ps.solution - in - let (goalss,evd) = Evd.Monad.List.map tac initgoals initevd in - let sgs = CList.flatten goalss in - let sgs = undefined evd sgs in - InfoL.leaf (Info.Tactic (fun () -> Pp.str"")) >> - Pv.set { ps with solution = evd; comb = sgs; } - with e when catchable_exception e -> - let (e, info) = Errors.push e in - tclZERO ~info e - - - (* normalises the evars in the goals, and stores the result in - solution. *) - let nf_evar_goals = - Pv.modify begin fun ps -> - let map g s = goal_nf_evar s g in - let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in - { ps with solution = evd; comb = goals; } - end - - let has_unresolved_evar pv = - Evd.has_undefined pv.solution - - (* Main function in the implementation of Grab Existential Variables.*) - let grab pv = - let undef = Evd.undefined_map pv.solution in - let goals = CList.rev_map fst (Evar.Map.bindings undef) in - { pv with comb = goals } - - - - (* Returns the open goals of the proofview together with the evar_map to - interpret them. *) - let goals { comb = comb ; solution = solution; } = - { Evd.it = comb ; sigma = solution } - - let top_goals initial { solution=solution; } = - let goals = CList.map (fun (t,_) -> fst (Term.destEvar t)) initial in - { Evd.it = goals ; sigma=solution; } - - let top_evars initial = - let evars_of_initial (c,_) = - Evar.Set.elements (Evd.evars_of_term c) - in - CList.flatten (CList.map evars_of_initial initial) - - let of_tactic t gls = - try - let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in - let (_,final,_,_) = apply (goal_env gls.Evd.sigma gls.Evd.it) t init in - { Evd.sigma = final.solution ; it = final.comb } - with Logic_monad.TacticFailure e as src -> - let (_, info) = Errors.push src in - iraise (e, info) - - let put_status = Status.put - - let catchable_exception = catchable_exception - - let wrap_exceptions f = - try f () - with e when catchable_exception e -> - let (e, info) = Errors.push e in tclZERO ~info e - -end - -(** {7 Notations} *) - -module Notations = struct - let (>>=) = tclBIND - let (<*>) = tclTHEN - let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) - type ('a, 'b) enter = ('a, 'b) Goal.enter = - { enter : 'r. ('a, 'r) Goal.t -> 'b } - type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = - { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } -end diff --git a/proofs/proofview.mli b/proofs/proofview.mli deleted file mode 100644 index 6bc2e9a0ed..0000000000 --- a/proofs/proofview.mli +++ /dev/null @@ -1,586 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Goal.goal list * Evd.evar_map - - -(** {6 Starting and querying a proof view} *) - -(** Abstract representation of the initial goals of a proof. *) -type entry - -(** Optimize memory consumption *) -val compact : entry -> proofview -> entry * proofview - -(** Initialises a proofview, the main argument is a list of - environments (including a [named_context] which are used as - hypotheses) pair with conclusion types, creating accordingly many - initial goals. Because a proof does not necessarily starts in an - empty [evar_map] (indeed a proof can be triggered by an incomplete - pretyping), [init] takes an additional argument to represent the - initial [evar_map]. *) -val init : Evd.evar_map -> (Environ.env * Term.types) list -> entry * proofview - -(** A [telescope] is a list of environment and conclusion like in - {!init}, except that each element may depend on the previous - goals. The telescope passes the goals in the form of a - [Term.constr] which represents the goal as an [evar]. The - [evar_map] is threaded in state passing style. *) -type telescope = - | TNil of Evd.evar_map - | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope) - -(** Like {!init}, but goals are allowed to be dependent on one - another. Dependencies between goals is represented with the type - [telescope] instead of [list]. Note that the first [evar_map] of - the telescope plays the role of the [evar_map] argument in - [init]. *) -val dependent_init : telescope -> entry * proofview - -(** [finished pv] is [true] if and only if [pv] is complete. That is, - if it has an empty list of focused goals. There could still be - unsolved subgoaled, but they would then be out of focus. *) -val finished : proofview -> bool - -(** Returns the current [evar] state. *) -val return : proofview -> Evd.evar_map - -val partial_proof : entry -> proofview -> constr list -val initial_goals : entry -> (constr * types) list - - - -(** {6 Focusing commands} *) - -(** A [focus_context] represents the part of the proof view which has - been removed by a focusing action, it can be used to unfocus later - on. *) -type focus_context - -(** Returns a stylised view of a focus_context for use by, for - instance, ide-s. *) -(* spiwack: the type of [focus_context] will change as we push more - refined functions to ide-s. This would be better than spawning a - new nearly identical function everytime. Hence the generic name. *) -(* In this version: the goals in the context, as a "zipper" (the first - list is in reversed order). *) -val focus_context : focus_context -> Goal.goal list * Goal.goal list - -(** [focus i j] focuses a proofview on the goals from index [i] to - index [j] (inclusive, goals are indexed from [1]). I.e. goals - number [i] to [j] become the only focused goals of the returned - proofview. It returns the focused proofview, and a context for - the focus stack. *) -val focus : int -> int -> proofview -> proofview * focus_context - -(** Unfocuses a proofview with respect to a context. *) -val unfocus : focus_context -> proofview -> proofview - - -(** {6 The tactic monad} *) - -(** - Tactics are objects which apply a transformation to all the - subgoals of the current view at the same time. By opposition to - the old vision of applying it to a single goal. It allows tactics - such as [shelve_unifiable], tactics to reorder the focused goals, - 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). Another benefit is that it is possible to write tactics - that can be executed even if there are no focused goals. - - Tactics form a monad ['a tactic], in a sense a tactic can be - seen as a function (without argument) which returns a value of - type 'a and modifies the environment (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 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") and [Proofview.tclTHEN] - (which is a specialized bind on unit-returning tactics). - - Tactics have support for full-backtracking. Tactics can be seen - having multiple success: if after returning the first success a - failure is encountered, the tactic can backtrack and use a second - success if available. The state is backtracked to its previous - value, except the non-logical state defined in the {!NonLogical} - module below. -*) - - -(** The abstract type of tactics *) -type +'a tactic - -(** Applies a tactic to the current proofview. Returns a tuple - [a,pv,(b,sh,gu)] where [a] is the return value of the tactic, [pv] - is the updated proofview, [b] a boolean which is [true] if the - tactic has not done any action considered unsafe (such as - admitting a lemma), [sh] is the list of goals which have been - shelved by the tactic, and [gu] the list of goals on which the - tactic has given up. In case of multiple success the first one is - selected. If there is no success, fails with - {!Logic_monad.TacticFailure}*) -val apply : Environ.env -> 'a tactic -> proofview -> 'a - * proofview - * (bool*Goal.goal list*Goal.goal list) - * Proofview_monad.Info.tree - -(** {7 Monadic primitives} *) - -(** 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 - -(** Interprets the ";" (semicolon) of Ltac. As a monadic operation, - it's a specialized "bind". *) -val tclTHEN : unit tactic -> 'a tactic -> 'a tactic - -(** [tclIGNORE t] has the same operational content as [t], but drops - the returned value. *) -val tclIGNORE : 'a tactic -> unit tactic - -(** Generic monadic combinators for tactics. *) -module Monad : Monad.S with type +'a t = 'a tactic - -(** {7 Failure and backtracking} *) - -(** [tclZERO e] fails with exception [e]. It has no success. *) -val tclZERO : ?info:Exninfo.info -> exn -> 'a tactic - -(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever - the successes of [t1] have been depleted and it failed with [e], - then it behaves as [t2 e]. In other words, [tclOR] inserts a - backtracking point. *) -val tclOR : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic - -(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one - success or [t2 e] if [t1] fails with [e]. It is analogous to - [try/with] handler of exception in that it is not a backtracking - point. *) -val tclORELSE : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic - -(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a] - succeeds at least once then it behaves as [tclBIND a s] otherwise, - if [a] fails with [e], then it behaves as [f e]. *) -val tclIFCATCH : 'a tactic -> ('a -> 'b tactic) -> (iexn -> 'b tactic) -> 'b tactic - -(** [tclONCE t] behave like [t] except it has at most one success: - [tclONCE t] stops after the first success of [t]. If [t] fails - with [e], [tclONCE t] also fails with [e]. *) -val tclONCE : 'a tactic -> 'a tactic - -(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one - success. Otherwise it fails. The tactic [t] is run until its first - success, then a failure with exception [e] is simulated. It [t] - yields another success, then [tclEXACTLY_ONCE e t] fails with - [MoreThanOneSuccess] (it is a user error). Otherwise, - [tclEXACTLY_ONCE e t] succeeds with the first success of - [t]. Notice that the choice of [e] is relevant, as the presence of - further successes may depend on [e] (see {!tclOR}). *) -exception MoreThanOneSuccess -val tclEXACTLY_ONCE : exn -> 'a tactic -> 'a tactic - -(** [tclCASE t] splits [t] into its first success and a - continuation. It is the most general primitive to control - backtracking. *) -type 'a case = - | Fail of iexn - | Next of 'a * (iexn -> 'a tactic) -val tclCASE : 'a tactic -> 'a case tactic - -(** [tclBREAK p t] is a generalization of [tclONCE t]. Instead of - stopping after the first success, it succeeds like [t] until a - failure with an exception [e] such that [p e = Some e'] is raised. At - which point it drops the remaining successes, failing with [e']. - [tclONCE t] is equivalent to [tclBREAK (fun e -> Some e) t]. *) -val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic - - -(** {7 Focusing tactics} *) - -(** [tclFOCUS i j t] applies [t] after focusing on the goals number - [i] to [j] (see {!focus}). The rest of the goals is restored after - the tactic action. If the specified range doesn't correspond to - existing goals, fails with [NoSuchGoals] (a user error). this - exception is caught at toplevel with a default message + a hook - message that can be customized by [set_nosuchgoals_hook] below. - This hook is used to add a suggestion about bullets when - applicable. *) -exception NoSuchGoals of int -val set_nosuchgoals_hook: (int -> Pp.std_ppcmds) -> unit - -val tclFOCUS : int -> int -> 'a tactic -> 'a tactic - -(** [tclFOCUSID x t] applies [t] on a (single) focused goal like - {!tclFOCUS}. The goal is found by its name rather than its - number.*) -val tclFOCUSID : Names.Id.t -> 'a tactic -> 'a tactic - -(** [tclTRYFOCUS i j t] behaves like {!tclFOCUS}, except that if the - specified range doesn't correspond to existing goals, behaves like - [tclUNIT ()] instead of failing. *) -val tclTRYFOCUS : int -> int -> unit tactic -> unit tactic - - -(** {7 Dispatching on goals} *) - -(** Dispatch tacticals are used to apply a different tactic to each - goal under focus. They come in two flavours: [tclDISPATCH] takes a - list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL] - takes a list of ['a tactic] and returns an ['a list tactic]. - - They both work by applying each of the tactic in a focus - restricted to the corresponding goal (starting with the first - goal). In the case of [tclDISPATCHL], the tactic returns a list of - the same size as the argument list (of tactics), each element - being the result of the tactic executed in the corresponding goal. - - When the length of the tactic list is not the number of goal, - raises [SizeMismatch (g,t)] where [g] is the number of available - goals, and [t] the number of tactics passed. *) -exception SizeMismatch of int*int -val tclDISPATCH : unit tactic list -> unit tactic -val tclDISPATCHL : 'a tactic list -> 'a list tactic - -(** [tclEXTEND b r e] is a variant of {!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 - -(** [tclINDEPENDENT tac] runs [tac] on each goal successively, from - the first one to the last one. Backtracking in one goal is - independent of backtracking in another. It is equivalent to - [tclEXTEND [] tac []]. *) -val tclINDEPENDENT : unit tactic -> unit tactic - - -(** {7 Goal manipulation} *) - -(** Shelves all the goals under focus. The goals are placed on the - shelf for later use (or being solved by side-effects). *) -val shelve : unit tactic - -(** Shelves the unifiable goals under focus, i.e. the goals which - appear in other goals under focus (the unfocused goals are not - considered). *) -val shelve_unifiable : unit tactic - -(** [guard_no_unifiable] returns the list of unifiable goals if some - goals are unifiable (see {!shelve_unifiable}) in the current focus. *) -val guard_no_unifiable : Names.Name.t list option tactic - -(** [unshelve l p] adds all the goals in [l] at the end of the focused - goals of p *) -val unshelve : Goal.goal list -> proofview -> proofview - -(** [with_shelf tac] executes [tac] and returns its result together with the set - of goals shelved by [tac]. The current shelf is unchanged. *) -val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic - -(** If [n] is positive, [cycle n] puts the [n] first goal last. If [n] - is negative, then it puts the [n] last goals first.*) -val cycle : int -> unit tactic - -(** [swap i j] swaps the position of goals number [i] and [j] - (negative numbers can be used to address goals from the end. Goals - are indexed from [1]. For simplicity index [0] corresponds to goal - [1] as well, rather than raising an error. *) -val swap : int -> int -> unit tactic - -(** [revgoals] reverses the list of focused goals. *) -val revgoals : unit tactic - -(** [numgoals] returns the number of goals under focus. *) -val numgoals : int tactic - - -(** {7 Access primitives} *) - -(** [tclEVARMAP] doesn't affect the proof, it returns the current - [evar_map]. *) -val tclEVARMAP : Evd.evar_map tactic - -(** [tclENV] doesn't affect the proof, it returns the current - environment. It is not the environment of a particular goal, - rather the "global" environment of the proof. The goal-wise - environment is obtained via {!Proofview.Goal.env}. *) -val tclENV : Environ.env tactic - - -(** {7 Put-like primitives} *) - -(** [tclEFFECTS eff] add the effects [eff] to the current state. *) -val tclEFFECTS : Safe_typing.private_constants -> unit tactic - -(** [mark_as_unsafe] declares the current tactic is unsafe. *) -val mark_as_unsafe : unit tactic - -(** Gives up on the goal under focus. Reports an unsafe status. Proofs - with given up goals cannot be closed. *) -val give_up : unit tactic - - -(** {7 Control primitives} *) - -(** [tclPROGRESS t] checks the state of the proof after [t]. It it is - identical to the state before, then [tclePROGRESS t] fails, otherwise - it succeeds like [t]. *) -val tclPROGRESS : 'a tactic -> 'a tactic - -(** Checks for interrupts *) -val tclCHECKINTERRUPT : unit tactic - -exception Timeout -(** [tclTIMEOUT n t] can have only one success. - In case of timeout if fails with [tclZERO Timeout]. *) -val tclTIMEOUT : int -> 'a tactic -> 'a tactic - -(** [tclTIME s t] displays time for each atomic call to t, using s as an - identifying annotation if present *) -val tclTIME : string option -> 'a tactic -> 'a tactic - -(** {7 Unsafe primitives} *) - -(** The primitives in the [Unsafe] module should be avoided as much as - possible, since they can make the proof state inconsistent. They are - nevertheless helpful, in particular when interfacing the pretyping and - the proof engine. *) -module Unsafe : sig - - (** [tclEVARS sigma] replaces the current [evar_map] by [sigma]. If - [sigma] has new unresolved [evar]-s they will not appear as - goal. If goals have been solved in [sigma] they will still - appear as unsolved goals. *) - val tclEVARS : Evd.evar_map -> unit tactic - - (** Like {!tclEVARS} but also checks whether goals have been solved. *) - val tclEVARSADVANCE : Evd.evar_map -> unit tactic - - (** [tclNEWGOALS gls] adds the goals [gls] to the ones currently - being proved, appending them to the list of focused goals. If a - goal is already solved, it is not added. *) - val tclNEWGOALS : Goal.goal list -> unit tactic - - (** [tclSETGOALS gls] sets goals [gls] as the goals being under focus. If a - goal is already solved, it is not set. *) - val tclSETGOALS : Goal.goal list -> unit tactic - - (** [tclGETGOALS] returns the list of goals under focus. *) - val tclGETGOALS : Goal.goal list tactic - - (** Sets the evar universe context. *) - val tclEVARUNIVCONTEXT : Evd.evar_universe_context -> unit tactic - - (** Clears the future goals store in the proof view. *) - val reset_future_goals : proofview -> proofview - - (** Give an evar the status of a goal (changes its source location - and makes it unresolvable for type classes. *) - val mark_as_goal : Evd.evar_map -> Evar.t -> Evd.evar_map - - (** [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. *) - val advance : Evd.evar_map -> Evar.t -> Evar.t option -end - -(** This module gives access to the innards of the monad. Its use is - restricted to very specific cases. *) -module UnsafeRepr : -sig - type state = Proofview_monad.Logical.Unsafe.state - val repr : 'a tactic -> ('a, state, state, iexn) Logic_monad.BackState.t - val make : ('a, state, state, iexn) Logic_monad.BackState.t -> 'a tactic -end - -(** {6 Goal-dependent tactics} *) - -module Goal : sig - - (** Type of goals. - - The first parameter type is a phantom argument indicating whether the data - contained in the goal has been normalized w.r.t. the current sigma. If it - is the case, it is flagged [ `NF ]. You may still access the un-normalized - data using {!assume} if you known you do not rely on the assumption of - being normalized, at your own risk. - - The second parameter is a stage indicating where the goal belongs. See - module {!Sigma}. - *) - type ('a, 'r) t - - (** Assume that you do not need the goal to be normalized. *) - val assume : ('a, 'r) t -> ([ `NF ], 'r) t - - (** Normalises the argument goal. *) - val normalize : ('a, 'r) t -> ([ `NF ], 'r) t tactic - - (** [concl], [hyps], [env] and [sigma] given a goal [gl] return - respectively the conclusion of [gl], the hypotheses of [gl], the - environment of [gl] (i.e. the global environment and the - hypotheses) and the current evar map. *) - val concl : ([ `NF ], 'r) t -> Term.constr - val hyps : ([ `NF ], 'r) t -> Context.Named.t - val env : ('a, 'r) t -> Environ.env - val sigma : ('a, 'r) t -> 'r Sigma.t - val extra : ('a, 'r) t -> Evd.Store.t - - (** Returns the goal's conclusion even if the goal is not - normalised. *) - val raw_concl : ('a, 'r) t -> Term.constr - - type ('a, 'b) enter = - { enter : 'r. ('a, 'r) t -> 'b } - - (** [nf_enter t] applies the goal-dependent tactic [t] in each goal - independently, in the manner of {!tclINDEPENDENT} except that - the current goal is also given as an argument to [t]. The goal - is normalised with respect to evars. *) - val nf_enter : ([ `NF ], unit tactic) enter -> unit tactic - - (** Like {!nf_enter}, but does not normalize the goal beforehand. *) - val enter : ([ `LZ ], unit tactic) enter -> unit tactic - - type ('a, 'b) s_enter = - { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } - - (** A variant of {!enter} allows to work with a monotonic state. The evarmap - returned by the argument is put back into the current state before firing - the returned tactic. *) - val s_enter : ([ `LZ ], unit tactic) s_enter -> unit tactic - - (** Like {!s_enter}, but normalizes the goal beforehand. *) - val nf_s_enter : ([ `NF ], unit tactic) s_enter -> unit tactic - - (** Recover the list of current goals under focus, without evar-normalization. - FIXME: encapsulate the level in an existential type. *) - val goals : ([ `LZ ], 'r) t tactic list tactic - - (** Compatibility: avoid if possible *) - val goal : ([ `NF ], 'r) t -> Evar.t - - (** Every goal is valid at a later stage. FIXME: take a later evarmap *) - val lift : ('a, 'r) t -> ('r, 's) Sigma.le -> ('a, 's) t - -end - - -(** {6 Trace} *) - -module Trace : sig - - (** [record_info_trace t] behaves like [t] except the [info] trace - is stored. *) - val record_info_trace : 'a tactic -> 'a tactic - - val log : Proofview_monad.lazy_msg -> unit tactic - val name_tactic : Proofview_monad.lazy_msg -> 'a tactic -> 'a tactic - - val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.std_ppcmds - -end - - -(** {6 Non-logical state} *) - -(** The [NonLogical] module allows the execution of effects (including - I/O) in tactics (non-logical side-effects are not discarded at - failures). *) -module NonLogical : module type of Logic_monad.NonLogical - -(** [tclLIFT c] is a tactic which behaves exactly as [c]. *) -val tclLIFT : 'a NonLogical.t -> 'a tactic - - -(**/**) - -(*** Compatibility layer with <= 8.2 tactics ***) -module V82 : sig - type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma - val tactic : tac -> unit tactic - - (* normalises the evars in the goals, and stores the result in - solution. *) - val nf_evar_goals : unit tactic - - val has_unresolved_evar : proofview -> bool - - (* Main function in the implementation of Grab Existential Variables. - Resets the proofview's goals so that it contains all unresolved evars - (in chronological order of insertion). *) - val grab : proofview -> proofview - - (* Returns the open goals of the proofview together with the evar_map to - interpret them. *) - val goals : proofview -> Evar.t list Evd.sigma - - val top_goals : entry -> proofview -> Evar.t list Evd.sigma - - (* returns the existential variable used to start the proof *) - val top_evars : entry -> Evd.evar list - - (* Caution: this function loses quite a bit of information. It - should be avoided as much as possible. It should work as - expected for a tactic obtained from {!V82.tactic} though. *) - val of_tactic : 'a tactic -> tac - - (* marks as unsafe if the argument is [false] *) - val put_status : bool -> unit tactic - - (* exception for which it is deemed to be safe to transmute into - tactic failure. *) - val catchable_exception : exn -> bool - - (* transforms every Ocaml (catchable) exception into a failure in - the monad. *) - val wrap_exceptions : (unit -> 'a tactic) -> 'a tactic -end - -(** {7 Notations} *) - -module Notations : sig - - (** {!tclBIND} *) - val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic - (** {!tclTHEN} *) - val (<*>) : unit tactic -> 'a tactic -> 'a tactic - (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) - val (<+>) : 'a tactic -> 'a tactic -> 'a tactic - - type ('a, 'b) enter = ('a, 'b) Goal.enter = - { enter : 'r. ('a, 'r) Goal.t -> 'b } - type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = - { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } -end -- cgit v1.2.3 From a0e792236c9666df1069753f8f807c12f713dcfb Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 23 Mar 2016 16:03:47 +0100 Subject: refine: do check all unif problems are solved (Close: #4415, #4532) This fixes a class of bugs like refine foo; tactic. where tactic fails (by resuming the remaining, unsolvable, problems) while in 8.4 refine was failing. It is not clear to us (Maxime and myself) if we should call consider_remaining_unif_problems instead of check_problems_are_solved. --- proofs/proofview.ml | 1 + 1 file changed, 1 insertion(+) (limited to 'proofs') diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 6d7dcb9257..80569e2342 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -1061,6 +1061,7 @@ struct let typecheck_proof c concl env sigma = let evdref = ref sigma in let () = Typing.check env evdref c concl in + Evarconv.check_problems_are_solved env !evdref; !evdref let (pr_constrv,pr_constr) = -- cgit v1.2.3 From 31ffc14b4b8d531777042d3ff02f34985bcec084 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 23 Mar 2016 18:26:00 +0100 Subject: Revert "refine: do check all unif problems are solved (Close: #4415, #4532)" This fix is too restrictive. Still, opening a goal for an evar with a pending conv_pb is unsafe since the user may prove (instantiate it) in a way not compatible with the conv_pb. Assigning an evar, in its lowest level API, should enforce that all related conv_pbs are satisfied by the instance. This also poses a UI problem, since there is not way to see these conv_pbs. One could print a goal and say: look, the proof term you give must validate this equation... Given that the good fix is not obvious, we revert! This reverts commit a0e792236c9666df1069753f8f807c12f713dcfb. --- proofs/proofview.ml | 1 - 1 file changed, 1 deletion(-) (limited to 'proofs') diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 80569e2342..6d7dcb9257 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -1061,7 +1061,6 @@ struct let typecheck_proof c concl env sigma = let evdref = ref sigma in let () = Typing.check env evdref c concl in - Evarconv.check_problems_are_solved env !evdref; !evdref let (pr_constrv,pr_constr) = -- cgit v1.2.3 From 7e7b5684d8f8066b90fca3395104af7241b8aed6 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 25 Mar 2016 16:46:50 +0100 Subject: Univs: fix get_current_context (bug #4603, part I) Return an evar_map with the right universes, when there are no focused subgoals or the proof is finished. --- proofs/pfedit.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'proofs') diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index b635cc9632..2f5c1d1c2b 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -85,7 +85,8 @@ let get_current_goal_context () = with NoSuchGoal -> (* spiwack: returning empty evar_map, since if there is no goal, under focus, there is no accessible evar either *) - (Evd.empty, Global.env ()) + let env = Global.env () in + (Evd.from_env env, env) let current_proof_statement () = match Proof_global.V82.get_current_initial_conclusions () with -- cgit v1.2.3