diff options
Diffstat (limited to 'proofs')
| -rw-r--r-- | proofs/logic.ml | 2 | ||||
| -rw-r--r-- | proofs/pfedit.ml | 63 | ||||
| -rw-r--r-- | proofs/pfedit.mli | 157 | ||||
| -rw-r--r-- | proofs/proof.ml | 2 | ||||
| -rw-r--r-- | proofs/proof_global.ml | 9 | ||||
| -rw-r--r-- | proofs/refine.ml | 20 | ||||
| -rw-r--r-- | proofs/refine.mli | 13 |
7 files changed, 141 insertions, 125 deletions
diff --git a/proofs/logic.ml b/proofs/logic.ml index c329bdf4a..6af1b2d83 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -253,7 +253,7 @@ let move_hyp sigma toleft (left,declfrom,right) hto = else user_err ~hdr:"move_hyp" (str "Cannot move " ++ pr_id (NamedDecl.get_id declfrom) ++ Miscprint.pr_move_location pr_id hto ++ - str (if toleft then ": it occurs in " else ": it depends on ") + str (if toleft then ": it occurs in the type of " else ": it depends on ") ++ pr_id hyp ++ str ".") else (d::first, middle) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 3fb66d1b8..b28234a50 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -24,19 +24,6 @@ let _ = Goptions.declare_bool_option { let use_unification_heuristics () = !use_unification_heuristics_ref -let refining = Proof_global.there_are_pending_proofs -let check_no_pending_proofs = Proof_global.check_no_pending_proof - -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) ?pl str sigma hyps c ?init_tac terminator = let goals = [ (Global.env_of_context hyps , c) ] in Proof_global.start_proof sigma id ?pl str goals terminator; @@ -55,32 +42,20 @@ let cook_this_proof p = let cook_proof () = cook_this_proof (fst (Proof_global.close_proof ~keep_body_ucst_separate:false (fun x -> x))) -let get_pftreestate () = - Proof_global.give_me_the_proof () - -let set_end_tac tac = - Proof_global.set_endline_tactic tac - -let set_used_variables l = - Proof_global.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 _ = CErrors.register_handler begin function | NoSuchGoal -> CErrors.user_err Pp.(str "No such goal.") | _ -> raise CErrors.Unhandled end + let get_nth_V82_goal i = let p = Proof_global.give_me_the_proof () in let { it=goals ; sigma = sigma; } = Proof.V82.subgoals p in try { it=(List.nth goals (i-1)) ; sigma=sigma; } with Failure _ -> raise NoSuchGoal - + let get_goal_context_gen i = let { it=goal ; sigma=sigma; } = get_nth_V82_goal i in (sigma, Refiner.pf_env { it=goal ; sigma=sigma; }) @@ -106,7 +81,7 @@ let get_current_context () = (Evd.from_env env, env) | NoSuchGoal -> (* No more focused goals ? *) - let p = get_pftreestate () in + let p = Proof_global.give_me_the_proof () in let evd = Proof.in_proof p (fun x -> x) in (evd, Global.env ()) @@ -165,11 +140,11 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo try let status = by tac in let _,(const,univs,_) = cook_proof () in - delete_current_proof (); + Proof_global.discard_current (); const, status, fst univs with reraise -> let reraise = CErrors.push reraise in - delete_current_proof (); + Proof_global.discard_current (); iraise reraise let build_by_tactic ?(side_eff=true) env sigma ?(poly=false) typ tac = @@ -257,4 +232,32 @@ let solve_by_implicit_tactic () = match !implicit_tactic with | None -> None | Some tac -> Some (apply_implicit_tactic tac) +(** Deprecated functions *) +let refining = Proof_global.there_are_pending_proofs +let check_no_pending_proofs = Proof_global.check_no_pending_proof + +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 get_pftreestate () = + Proof_global.give_me_the_proof () + +let set_end_tac tac = + Proof_global.set_endline_tactic tac + +let set_used_variables l = + Proof_global.set_used_variables l + +let get_used_variables () = + Proof_global.get_used_variables () + +let get_universe_binders () = + Proof_global.get_universe_binders () diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 1bf65b8ae..f009593e9 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -14,39 +14,6 @@ open Term open Environ open Decl_kinds -(** Several proofs can be opened simultaneously but at most one is - focused at some time. The following functions work by side-effect - on current set of open proofs. In this module, ``proofs'' means an - open proof (something started by vernacular command [Goal], [Lemma] - or [Theorem]), and ``goal'' means a subgoal of the current focused - proof *) - -(** {6 ... } *) -(** [refining ()] tells if there is some proof in progress, even if a not - focused one *) - -val refining : unit -> bool - -(** [check_no_pending_proofs ()] fails if there is still some proof in - progress *) - -val check_no_pending_proofs : unit -> unit - -(** {6 ... } *) -(** [delete_proof name] deletes proof of name [name] or fails if no proof - has this name *) - -val delete_proof : Id.t located -> unit - -(** [delete_current_proof ()] deletes current focused proof or fails if - no proof is focused *) - -val delete_current_proof : unit -> unit - -(** [delete_all_proofs ()] deletes all open proofs if any *) - -val delete_all_proofs : unit -> unit - (** {6 ... } *) (** [start_proof s str env t hook tac] starts a proof of name [s] and conclusion [t]; [hook] is optionally a function to be applied at @@ -55,12 +22,8 @@ val delete_all_proofs : unit -> unit systematically apply at initialization time (e.g. to start the proof of mutually dependent theorems) *) -type lemma_possible_guards = Proof_global.lemma_possible_guards - -type universe_binders = Id.t Loc.located list - val start_proof : - Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> named_context_val -> EConstr.constr -> + Id.t -> ?pl:Proof_global.universe_binders -> goal_kind -> Evd.evar_map -> named_context_val -> EConstr.constr -> ?init_tac:unit Proofview.tactic -> Proof_global.proof_terminator -> unit @@ -80,11 +43,6 @@ val cook_proof : unit -> (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * goal_kind)) (** {6 ... } *) -(** [get_pftreestate ()] returns the current focused pending proof. - @raise NoCurrentProof if there is no pending proof. *) - -val get_pftreestate : unit -> Proof.proof - (** [get_goal_context n] returns the context of the [n]th subgoal of the current focused proof or raises a [UserError] if there is no focused proof or if there is no more subgoals *) @@ -109,34 +67,6 @@ val current_proof_statement : unit -> Id.t * goal_kind * EConstr.types (** {6 ... } *) -(** [get_current_proof_name ()] return the name of the current focused - proof or failed if no proof is focused *) - -val get_current_proof_name : unit -> Id.t - -(** [get_all_proof_names ()] returns the list of all pending proof names. - The first name is the current proof, the other names may come in - any order. *) - -val get_all_proof_names : unit -> Id.t list - -(** {6 ... } *) -(** [set_end_tac tac] applies tactic [tac] to all subgoal generate - by [solve] *) - -val set_end_tac : Genarg.glob_generic_argument -> 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.Named.t * Names.Id.t Loc.located list -val get_used_variables : unit -> Context.Named.t 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 proof is focused or if there is no [n]th subgoal. [solve SelectAll @@ -191,3 +121,88 @@ val clear_implicit_tactic : unit -> unit (* Raise Exit if cannot solve *) val solve_by_implicit_tactic : unit -> Pretyping.inference_hook option + +(** {5 Deprecated functions in favor of [Proof_global]} *) + +(** {6 ... } *) +(** Several proofs can be opened simultaneously but at most one is + focused at some time. The following functions work by side-effect + on current set of open proofs. In this module, ``proofs'' means an + open proof (something started by vernacular command [Goal], [Lemma] + or [Theorem]), and ``goal'' means a subgoal of the current focused + proof *) + +(** [refining ()] tells if there is some proof in progress, even if a not + focused one *) + +val refining : unit -> bool +[@@ocaml.deprecated "use Proof_global.there_are_pending_proofs"] + +(** [check_no_pending_proofs ()] fails if there is still some proof in + progress *) + +val check_no_pending_proofs : unit -> unit +[@@ocaml.deprecated "use Proof_global.check_no_pending_proofs"] + +(** {6 ... } *) +(** [delete_proof name] deletes proof of name [name] or fails if no proof + has this name *) + +val delete_proof : Id.t located -> unit +[@@ocaml.deprecated "use Proof_global.discard"] + +(** [delete_current_proof ()] deletes current focused proof or fails if + no proof is focused *) + +val delete_current_proof : unit -> unit +[@@ocaml.deprecated "use Proof_global.discard_current"] + +(** [delete_all_proofs ()] deletes all open proofs if any *) +val delete_all_proofs : unit -> unit +[@@ocaml.deprecated "use Proof_global.discard_all"] + +(** [get_pftreestate ()] returns the current focused pending proof. + @raise NoCurrentProof if there is no pending proof. *) + +val get_pftreestate : unit -> Proof.proof +[@@ocaml.deprecated "use Proof_global.give_me_the_proof"] + +(** {6 ... } *) +(** [set_end_tac tac] applies tactic [tac] to all subgoal generate + by [solve] *) + +val set_end_tac : Genarg.glob_generic_argument -> unit +[@@ocaml.deprecated "use Proof_global.set_endline_tactic"] + +(** {6 ... } *) +(** [set_used_variables l] declares that section variables [l] will be + used in the proof *) +val set_used_variables : + Id.t list -> Context.Named.t * Names.Id.t Loc.located list +[@@ocaml.deprecated "use Proof_global.set_used_variables"] + +val get_used_variables : unit -> Context.Named.t option +[@@ocaml.deprecated "use Proof_global.get_used_variables"] + +(** {6 Universe binders } *) +val get_universe_binders : unit -> Proof_global.universe_binders option +[@@ocaml.deprecated "use Proof_global.get_universe_binders"] + +(** {6 ... } *) +(** [get_current_proof_name ()] return the name of the current focused + proof or failed if no proof is focused *) +val get_current_proof_name : unit -> Id.t +[@@ocaml.deprecated "use Proof_global.get_current_proof_name"] + +(** [get_all_proof_names ()] returns the list of all pending proof names. + The first name is the current proof, the other names may come in + any order. *) +val get_all_proof_names : unit -> Id.t list +[@@ocaml.deprecated "use Proof_global.get_all_proof_names"] + +type lemma_possible_guards = Proof_global.lemma_possible_guards +[@@ocaml.deprecated "use Proof_global.lemma_possible_guards"] + +type universe_binders = Proof_global.universe_binders +[@@ocaml.deprecated "use Proof_global.universe_binders"] + diff --git a/proofs/proof.ml b/proofs/proof.ml index 2aa620c1d..ef454299e 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -428,7 +428,7 @@ module V82 = struct 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 ltac_vars = Glob_ops.empty_lvar in let sigma = Evar_refiner.w_refine (evk, evi) (ltac_vars, rawc) sigma in Proofview.Unsafe.tclEVARS sigma end in diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 5ec34a638..d5fbdbb83 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -336,15 +336,14 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now let make_body = if poly || now then let make_body t (c, eff) = - let open Universes in let body = c in let typ = 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 + let used_univs_body = Univops.universes_of_constr body in + let used_univs_typ = Univops.universes_of_constr typ in if keep_body_ucst_separate || not (Safe_typing.empty_private_constants = eff) then let initunivs = Evd.evar_context_universe_context initial_euctx in @@ -353,7 +352,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now * complement the univ constraints of the typ with the ones of * the body. So we keep the two sets distinct. *) let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let ctx_body = restrict_universe_context ctx used_univs in + let ctx_body = Univops.restrict_universe_context ctx used_univs in (initunivs, typ), ((body, ctx_body), eff) else let initunivs = Univ.UContext.empty in @@ -362,7 +361,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now * constraints in which we merge the ones for the body and the ones * for the typ *) let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let ctx = restrict_universe_context ctx used_univs in + let ctx = Univops.restrict_universe_context ctx used_univs in let univs = Univ.ContextSet.to_context ctx in (univs, typ), ((body, Univ.ContextSet.empty), eff) in diff --git a/proofs/refine.ml b/proofs/refine.ml index caa6b9fb3..796b4b837 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -69,7 +69,7 @@ let add_side_effect env = function let add_side_effects env effects = List.fold_left (fun env eff -> add_side_effect env eff) env effects -let generic_refine ?(unsafe = true) f gl = +let generic_refine ~typecheck f gl = let gl = Proofview.Goal.assume gl in let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in @@ -91,9 +91,9 @@ let generic_refine ?(unsafe = true) f gl = let env = add_side_effects env sideff 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 + let sigma = if typecheck then CList.fold_left fold sigma evs else sigma in (** Check that the refined term is typesafe *) - let sigma = if unsafe then sigma else typecheck_proof c concl env sigma in + let sigma = if typecheck then typecheck_proof c concl env sigma else sigma in (** Check that the goal itself does not appear in the refined term *) let self = Proofview.Goal.goal gl in let _ = @@ -132,16 +132,16 @@ let lift c = Proofview.tclUNIT c end -let make_refine_enter ?unsafe f gl = generic_refine ?unsafe (lift f) gl +let make_refine_enter ~typecheck f gl = generic_refine ~typecheck (lift f) gl -let refine_one ?(unsafe = true) f = - Proofview.Goal.enter_one (make_refine_enter ~unsafe f) +let refine_one ~typecheck f = + Proofview.Goal.enter_one (make_refine_enter ~typecheck f) -let refine ?(unsafe = true) f = +let refine ~typecheck f = let f evd = let (evd,c) = f evd in (evd,((), c)) in - Proofview.Goal.enter (make_refine_enter ~unsafe f) + Proofview.Goal.enter (make_refine_enter ~typecheck f) (** Useful definitions *) @@ -153,7 +153,7 @@ let with_type env evd c t = in evd , j'.Environ.uj_val -let refine_casted ?unsafe f = Proofview.Goal.enter begin fun gl -> +let refine_casted ~typecheck f = Proofview.Goal.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 @@ -161,7 +161,7 @@ let refine_casted ?unsafe f = Proofview.Goal.enter begin fun gl -> let (h, c) = f h in with_type env h c concl in - refine ?unsafe f + refine ~typecheck f end (** {7 solve_constraints} diff --git a/proofs/refine.mli b/proofs/refine.mli index f1439f9a1..c1c57ecb8 100644 --- a/proofs/refine.mli +++ b/proofs/refine.mli @@ -21,19 +21,18 @@ val pr_constr : (** {7 Refinement primitives} *) -val refine : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit tactic -(** In [refine ?unsafe t], [t] is a term with holes under some +val refine : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit tactic +(** In [refine ~typecheck 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. *) + tactic failures. If [typecheck] is [true] [t] is type-checked beforehand. *) -val refine_one : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * ('a * EConstr.t)) -> 'a tactic +val refine_one : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * ('a * EConstr.t)) -> 'a tactic (** A variant of [refine] which assumes exactly one goal under focus *) -val generic_refine : ?unsafe:bool -> ('a * EConstr.t) tactic -> +val generic_refine : typecheck:bool -> ('a * EConstr.t) tactic -> [ `NF ] Proofview.Goal.t -> 'a tactic (** The general version of refine. *) @@ -44,7 +43,7 @@ val with_type : Environ.env -> Evd.evar_map -> (** [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 * EConstr.t) -> unit tactic +val refine_casted : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit tactic (** Like {!refine} except the refined term is coerced to the conclusion of the current goal. *) |