aboutsummaryrefslogtreecommitdiff
path: root/proofs
diff options
context:
space:
mode:
Diffstat (limited to 'proofs')
-rw-r--r--proofs/logic.ml102
-rw-r--r--proofs/pfedit.ml25
-rw-r--r--proofs/pfedit.mli8
-rw-r--r--proofs/proof_global.ml10
-rw-r--r--proofs/proof_global.mli10
-rw-r--r--proofs/proof_type.mli3
-rw-r--r--proofs/proof_using.ml2
-rw-r--r--proofs/redexpr.ml4
-rw-r--r--proofs/refine.ml2
-rw-r--r--proofs/refiner.ml5
-rw-r--r--proofs/tacmach.ml11
-rw-r--r--proofs/tacmach.mli5
12 files changed, 48 insertions, 139 deletions
diff --git a/proofs/logic.ml b/proofs/logic.ml
index 09f308abef..fd8a70c650 100644
--- a/proofs/logic.ml
+++ b/proofs/logic.ml
@@ -77,10 +77,10 @@ let with_check = Flags.with_option check
(* [apply_to_hyp sign id f] splits [sign] into [tail::[id,_,_]::head] and
returns [tail::(f head (id,_,_) (rev tail))] *)
-let apply_to_hyp sign id f =
+let apply_to_hyp check sign id f =
try apply_to_hyp sign id f
with Hyp_not_found ->
- if !check then error_no_such_hypothesis id
+ if check then error_no_such_hypothesis id
else sign
let check_typability env sigma c =
@@ -493,7 +493,7 @@ let convert_hyp check sign sigma d =
let env = Global.env() in
let reorder = ref [] in
let sign' =
- apply_to_hyp sign id
+ apply_to_hyp check sign id
(fun _ d' _ ->
let _,c,ct = to_tuple d' in
let env = Global.env_of_context sign in
@@ -543,92 +543,6 @@ let prim_refiner r sigma goal =
let sigma = Goal.V82.partial_solution_to sigma goal sg2 oterm in
if b then ([sg1;sg2],sigma) else ([sg2;sg1],sigma)
- | FixRule (f,n,rest,j) ->
- let rec check_ind env k cl =
- match kind_of_term (strip_outer_cast cl) with
- | Prod (na,c1,b) ->
- if Int.equal k 1 then
- try
- fst (find_inductive env sigma c1)
- with Not_found ->
- error "Cannot do a fixpoint on a non inductive type."
- else
- 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
- let firsts,lasts = List.chop j rest in
- let all = firsts@(f,n,cl)::lasts in
- let rec mk_sign sign = function
- | (f,n,ar)::oth ->
- let ((sp',_),u') = check_ind env n ar in
- if not (eq_mind sp sp') then
- error "Fixpoints should be on the same mutual inductive declaration.";
- 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 (LocalAssum (f,ar)) sign) oth
- | [] ->
- Evd.Monad.List.map (fun (_,_,c) sigma ->
- let gl,ev,sig' =
- Goal.V82.mk_goal sigma sign c (Goal.V82.extra sigma goal) in
- (gl,ev),sig')
- all sigma
- in
- let (gls_evs,sigma) = mk_sign sign all in
- let (gls,evs) = List.split gls_evs in
- let ids = List.map pi1 all in
- let evs = List.map (Vars.subst_vars (List.rev ids)) evs in
- let indxs = Array.of_list (List.map (fun n -> n-1) (List.map pi2 all)) in
- let funnames = Array.of_list (List.map (fun i -> Name i) ids) in
- let typarray = Array.of_list (List.map pi3 all) in
- let bodies = Array.of_list evs in
- let oterm = Term.mkFix ((indxs,0),(funnames,typarray,bodies)) in
- let sigma = Goal.V82.partial_solution sigma goal oterm in
- (gls,sigma)
-
- | Cofix (f,others,j) ->
- let rec check_is_coind env cl =
- let b = whd_betadeltaiota env sigma cl in
- match kind_of_term b with
- | 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 ()
- with Not_found ->
- error "All methods must construct elements in coinductive types."
- in
- let firsts,lasts = List.chop j others in
- let all = firsts@(f,cl)::lasts in
- List.iter (fun (_,c) -> check_is_coind env c) all;
- let rec mk_sign sign = function
- | (f,ar)::oth ->
- (try
- (let _ = lookup_named_val f sign in
- error "Name already used in the environment.")
- with
- | Not_found ->
- mk_sign (push_named_context_val (LocalAssum (f,ar)) sign) oth)
- | [] ->
- Evd.Monad.List.map (fun (_,c) sigma ->
- let gl,ev,sigma =
- Goal.V82.mk_goal sigma sign c (Goal.V82.extra sigma goal) in
- (gl,ev),sigma)
- all sigma
- in
- let (gls_evs,sigma) = mk_sign sign all in
- let (gls,evs) = List.split gls_evs in
- let (ids,types) = List.split all in
- let evs = List.map (Vars.subst_vars (List.rev ids)) evs in
- let funnames = Array.of_list (List.map (fun i -> Name i) ids) in
- let typarray = Array.of_list types in
- let bodies = Array.of_list evs in
- let oterm = Term.mkCoFix (0,(funnames,typarray,bodies)) in
- let sigma = Goal.V82.partial_solution sigma goal oterm in
- (gls,sigma)
-
| Refine c ->
check_meta_variables c;
let (sgl,cl',sigma,oterm) = mk_refgoals sigma goal [] cl c in
@@ -636,16 +550,6 @@ let prim_refiner r sigma goal =
let sigma = Goal.V82.partial_solution sigma goal oterm in
(sgl, sigma)
- (* And now the structural rules *)
- | Thin ids ->
- let ids = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty ids in
- let (hyps,concl,nsigma) = clear_hyps env sigma ids sign cl in
- let (gl,ev,sigma) =
- Goal.V82.mk_goal nsigma hyps concl (Goal.V82.extra nsigma goal)
- in
- let sigma = Goal.V82.partial_solution_to sigma goal gl ev in
- ([gl], sigma)
-
| Move (hfrom, hto) ->
let (left,right,declfrom,toleft) =
split_sign hfrom hto (named_context_of_val sign) in
diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml
index 5367a907e5..2863384b59 100644
--- a/proofs/pfedit.ml
+++ b/proofs/pfedit.ml
@@ -71,23 +71,34 @@ let get_nth_V82_goal i =
with Failure _ -> raise NoSuchGoal
let get_goal_context_gen i =
- try
-let { it=goal ; sigma=sigma; } = get_nth_V82_goal i in
-(sigma, Refiner.pf_env { it=goal ; sigma=sigma; })
- with Proof_global.NoCurrentProof -> Errors.error "No focused proof."
+ let { it=goal ; sigma=sigma; } = get_nth_V82_goal i in
+ (sigma, Refiner.pf_env { it=goal ; sigma=sigma; })
let get_goal_context i =
try get_goal_context_gen i
- with NoSuchGoal -> Errors.error "No such goal."
+ with Proof_global.NoCurrentProof -> Errors.error "No focused proof."
+ | NoSuchGoal -> Errors.error "No such goal."
let get_current_goal_context () =
try get_goal_context_gen 1
- with NoSuchGoal ->
+ with Proof_global.NoCurrentProof -> Errors.error "No focused proof."
+ | NoSuchGoal ->
(* spiwack: returning empty evar_map, since if there is no goal, under focus,
there is no accessible evar either *)
let env = Global.env () in
(Evd.from_env env, env)
+let get_current_context () =
+ try get_goal_context_gen 1
+ with Proof_global.NoCurrentProof ->
+ let env = Global.env () in
+ (Evd.from_env env, env)
+ | NoSuchGoal ->
+ (* No more focused goals ? *)
+ let p = get_pftreestate () in
+ let evd = Proof.in_proof p (fun x -> x) in
+ (evd, Global.env ())
+
let current_proof_statement () =
match Proof_global.V82.get_current_initial_conclusions () with
| (id,([concl],strength)) -> id,strength,concl
@@ -111,7 +122,7 @@ let solve ?with_end_tac gi info_lvl tac pr =
let () =
match info_lvl with
| None -> ()
- | Some i -> Pp.msg_info (hov 0 (Proofview.Trace.pr_info ~lvl:i info))
+ | Some i -> Feedback.msg_info (hov 0 (Proofview.Trace.pr_info ~lvl:i info))
in
(p,status)
with
diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli
index cd89920151..cfab8bd630 100644
--- a/proofs/pfedit.mli
+++ b/proofs/pfedit.mli
@@ -93,6 +93,14 @@ val get_goal_context : int -> Evd.evar_map * env
val get_current_goal_context : unit -> Evd.evar_map * env
+(** [get_current_context ()] returns the context of the
+ current focused goal. If there is no focused goal but there
+ is a proof in progress, it returns the corresponding evar_map.
+ If there is no pending proof then it returns the current global
+ environment and empty evar_map. *)
+
+val get_current_context : unit -> Evd.evar_map * env
+
(** [current_proof_statement] *)
val current_proof_statement :
diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml
index 647dbe1115..36277bf58d 100644
--- a/proofs/proof_global.ml
+++ b/proofs/proof_global.ml
@@ -23,8 +23,9 @@ open Names
(* Type of proof modes :
- A function [set] to set it *from standard mode*
- A function [reset] to reset the *standard mode* from it *)
+type proof_mode_name = string
type proof_mode = {
- name : string ;
+ name : proof_mode_name ;
set : unit -> unit ;
reset : unit -> unit
}
@@ -45,6 +46,9 @@ let _ = register_proof_mode standard
(* Default proof mode, to be set at the beginning of proofs. *)
let default_proof_mode = ref (find_proof_mode "No")
+let get_default_proof_mode_name () =
+ (CEphemeron.default !default_proof_mode standard).name
+
let _ =
Goptions.declare_string_option {Goptions.
optsync = true ;
@@ -219,8 +223,8 @@ let set_proof_mode mn =
let activate_proof_mode mode =
CEphemeron.iter_opt (find_proof_mode mode) (fun x -> x.set ())
-let disactivate_proof_mode mode =
- CEphemeron.iter_opt (find_proof_mode mode) (fun x -> x.reset ())
+let disactivate_current_proof_mode () =
+ CEphemeron.iter_opt !current_proof_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
diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli
index ebe7f6d6f3..59daa29681 100644
--- a/proofs/proof_global.mli
+++ b/proofs/proof_global.mli
@@ -16,8 +16,9 @@
- A function [reset] to reset the *standard mode* from it
*)
+type proof_mode_name = string
type proof_mode = {
- name : string ;
+ name : proof_mode_name ;
set : unit -> unit ;
reset : unit -> unit
}
@@ -27,6 +28,7 @@ type proof_mode = {
One mode is already registered - the standard mode - named "No",
It corresponds to Coq default setting are they are set when coqtop starts. *)
val register_proof_mode : proof_mode -> unit
+val get_default_proof_mode_name : unit -> proof_mode_name
val there_are_pending_proofs : unit -> bool
val check_no_pending_proof : unit -> unit
@@ -40,7 +42,7 @@ val discard_all : unit -> unit
(** [set_proof_mode] sets the proof mode to be used after it's called. It is
typically called by the Proof Mode command. *)
-val set_proof_mode : string -> unit
+val set_proof_mode : proof_mode_name -> unit
exception NoCurrentProof
val give_me_the_proof : unit -> Proof.proof
@@ -153,8 +155,8 @@ val get_universe_binders : unit -> universe_binders option
(**********************************************************)
-val activate_proof_mode : string -> unit
-val disactivate_proof_mode : string -> unit
+val activate_proof_mode : proof_mode_name -> unit
+val disactivate_current_proof_mode : unit -> unit
(**********************************************************)
(* *)
diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli
index b4c9dae2a3..ef0d52b62d 100644
--- a/proofs/proof_type.mli
+++ b/proofs/proof_type.mli
@@ -19,10 +19,7 @@ open Misctypes
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 *)
diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml
index 681a7fa1ad..caa9b328a0 100644
--- a/proofs/proof_using.ml
+++ b/proofs/proof_using.ml
@@ -128,7 +128,7 @@ let suggest_Proof_using name env vars ids_typ context_ids =
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 (
+ Feedback.msg_info (
str"The proof of "++ str name ++ spc() ++
str "should start with one of the following commands:"++spc()++
v 0 (
diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml
index 2d886b8e1f..13b5848a33 100644
--- a/proofs/redexpr.ml
+++ b/proofs/redexpr.ml
@@ -31,7 +31,7 @@ let cbv_vm env sigma c =
let cbv_native env sigma c =
if Coq_config.no_native_compiler then
- let () = msg_warning (str "native_compute disabled at configure time; falling back to vm_compute.") in
+ let () = Feedback.msg_warning (str "native_compute disabled at configure time; falling back to vm_compute.") in
cbv_vm env sigma c
else
let ctyp = Retyping.get_type_of env sigma c in
@@ -221,7 +221,7 @@ let reduction_of_red_expr env =
let am = if !simplIsCbn then strong_cbn (make_flag f) else simpl in
let () =
if not (!simplIsCbn || List.is_empty f.rConst) then
- Pp.msg_warning (Pp.strbrk "The legacy simpl does not deal with delta flags.") in
+ Feedback.msg_warning (Pp.strbrk "The legacy simpl does not deal with delta flags.") in
(contextualize (if head_style then whd_am else am) am o,DEFAULTcast)
| Cbv f -> (e_red (cbv_norm_flags (make_flag f)),DEFAULTcast)
| Cbn f ->
diff --git a/proofs/refine.ml b/proofs/refine.ml
index db0b26f7e5..76e2d7dc53 100644
--- a/proofs/refine.ml
+++ b/proofs/refine.ml
@@ -6,9 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Pp
open Util
-open Proofview_monad
open Sigma.Notations
open Proofview.Notations
open Context.Named.Declaration
diff --git a/proofs/refiner.ml b/proofs/refiner.ml
index 186525e159..23433692cd 100644
--- a/proofs/refiner.ml
+++ b/proofs/refiner.ml
@@ -57,7 +57,7 @@ let tclIDTAC gls = goal_goal_list gls
(* the message printing identity tactic *)
let tclIDTAC_MESSAGE s gls =
- Pp.msg_info (hov 0 s); pp_flush (); tclIDTAC gls
+ Feedback.msg_info (hov 0 s); tclIDTAC gls
(* General failure tactic *)
let tclFAIL_s s gls = errorlabstrm "Refiner.tclFAIL_s" (str s)
@@ -218,7 +218,8 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma)
(fun acc d -> (Names.Id.to_string (get_id d)) ^ " " ^ acc)
"" lh))
"" newhyps in
- pp (str (emacs_str "<infoH>")
+ Feedback.msg_notice
+ (str (emacs_str "<infoH>")
++ (hov 0 (str s))
++ (str (emacs_str "</infoH>")) ++ fnl());
tclIDTAC goal;;
diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml
index 33cef7486b..8c0b4ba98a 100644
--- a/proofs/tacmach.ml
+++ b/proofs/tacmach.ml
@@ -121,25 +121,14 @@ let internal_cut_rev_no_check replace id t gl =
let refine_no_check c gl =
refiner (Refine c) gl
-(* This does not check dependencies *)
-let thin_no_check ids gl =
- if List.is_empty ids then tclIDTAC gl else refiner (Thin ids) gl
-
let move_hyp_no_check id1 id2 gl =
refiner (Move (id1,id2)) gl
-let mutual_fix f n others j gl =
- with_check (refiner (FixRule (f,n,others,j))) gl
-
-let mutual_cofix f others j gl =
- with_check (refiner (Cofix (f,others,j))) gl
-
(* Versions with consistency checks *)
let internal_cut b d t = with_check (internal_cut_no_check b d t)
let internal_cut_rev b d t = with_check (internal_cut_rev_no_check b d t)
let refine c = with_check (refine_no_check c)
-let thin c = with_check (thin_no_check c)
let move_hyp id id' = with_check (move_hyp_no_check id id')
(* Pretty-printers *)
diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli
index f786b5f218..182433cb3a 100644
--- a/proofs/tacmach.mli
+++ b/proofs/tacmach.mli
@@ -86,17 +86,12 @@ val pf_is_matching : goal sigma -> constr_pattern -> constr -> bool
val refiner : rule -> tactic
val internal_cut_no_check : bool -> Id.t -> types -> tactic
val refine_no_check : constr -> tactic
-val thin_no_check : Id.t list -> tactic
-val mutual_fix :
- Id.t -> int -> (Id.t * int * constr) list -> int -> tactic
-val mutual_cofix : Id.t -> (Id.t * constr) list -> int -> tactic
(** {6 The most primitive tactics with consistency and type checking } *)
val internal_cut : bool -> Id.t -> types -> tactic
val internal_cut_rev : bool -> Id.t -> types -> tactic
val refine : constr -> tactic
-val thin : Id.t list -> tactic
val move_hyp : Id.t -> Id.t move_location -> tactic
(** {6 Pretty-printing functions (debug only). } *)
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-02 15:28:30 +0000