aboutsummaryrefslogtreecommitdiffhomepage
path: root/proofs
diff options
context:
space:
mode:
Diffstat (limited to 'proofs')
-rw-r--r--proofs/clenv.ml2
-rw-r--r--proofs/clenv.mli8
-rw-r--r--proofs/clenvtac.ml5
-rw-r--r--proofs/goal.mli2
-rw-r--r--proofs/logic.ml45
-rw-r--r--proofs/logic.mli6
-rw-r--r--proofs/pfedit.ml3
-rw-r--r--proofs/pfedit.mli6
-rw-r--r--proofs/proof.ml4
-rw-r--r--proofs/proof.mli60
-rw-r--r--proofs/proof_bullet.ml8
-rw-r--r--proofs/proof_bullet.mli10
-rw-r--r--proofs/proof_global.ml46
-rw-r--r--proofs/proof_global.mli25
-rw-r--r--proofs/redexpr.ml15
-rw-r--r--proofs/refine.ml2
-rw-r--r--proofs/refine.mli2
-rw-r--r--proofs/refiner.ml4
-rw-r--r--proofs/refiner.mli2
-rw-r--r--proofs/tacmach.ml19
-rw-r--r--proofs/tacmach.mli56
21 files changed, 161 insertions, 169 deletions
diff --git a/proofs/clenv.ml b/proofs/clenv.ml
index 16798a1d5..9e06d913b 100644
--- a/proofs/clenv.ml
+++ b/proofs/clenv.ml
@@ -498,7 +498,7 @@ let clenv_unify_binding_type clenv c t u =
let clenv_assign_binding clenv k c =
let k_typ = clenv_hnf_constr clenv (clenv_meta_type clenv k) in
- let c_typ = nf_betaiota clenv.evd (clenv_get_type_of clenv c) in
+ let c_typ = nf_betaiota clenv.env clenv.evd (clenv_get_type_of clenv c) in
let status,clenv',c = clenv_unify_binding_type clenv c c_typ k_typ in
let c = EConstr.Unsafe.to_constr c in
{ clenv' with evd = meta_assign k (c,(Conv,status)) clenv'.evd }
diff --git a/proofs/clenv.mli b/proofs/clenv.mli
index 9a2026dd3..c894b9dc9 100644
--- a/proofs/clenv.mli
+++ b/proofs/clenv.mli
@@ -41,10 +41,10 @@ val clenv_nf_meta : clausenv -> EConstr.constr -> EConstr.constr
(** type of a meta in clenv context *)
val clenv_meta_type : clausenv -> metavariable -> types
-val mk_clenv_from : 'a Proofview.Goal.t -> EConstr.constr * EConstr.types -> clausenv
+val mk_clenv_from : Proofview.Goal.t -> EConstr.constr * EConstr.types -> clausenv
val mk_clenv_from_n :
- 'a Proofview.Goal.t -> int option -> EConstr.constr * EConstr.types -> clausenv
-val mk_clenv_type_of : 'a Proofview.Goal.t -> EConstr.constr -> clausenv
+ Proofview.Goal.t -> int option -> EConstr.constr * EConstr.types -> clausenv
+val mk_clenv_type_of : Proofview.Goal.t -> EConstr.constr -> clausenv
val mk_clenv_from_env : env -> evar_map -> int option -> EConstr.constr * EConstr.types -> clausenv
(** Refresh the universes in a clenv *)
@@ -66,7 +66,7 @@ val old_clenv_unique_resolver :
?flags:unify_flags -> clausenv -> Goal.goal sigma -> clausenv
val clenv_unique_resolver :
- ?flags:unify_flags -> clausenv -> 'a Proofview.Goal.t -> clausenv
+ ?flags:unify_flags -> clausenv -> Proofview.Goal.t -> clausenv
val clenv_dependent : clausenv -> metavariable list
diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml
index 4a92c3856..373d60e69 100644
--- a/proofs/clenvtac.ml
+++ b/proofs/clenvtac.ml
@@ -54,9 +54,10 @@ let clenv_value_cast_meta clenv =
let clenv_pose_dependent_evars with_evars clenv =
let dep_mvs = clenv_dependent clenv in
+ let env, sigma = clenv.env, clenv.evd in
if not (List.is_empty dep_mvs) && not with_evars then
raise
- (RefinerError (UnresolvedBindings (List.map (meta_name clenv.evd) dep_mvs)));
+ (RefinerError (env, sigma, UnresolvedBindings (List.map (meta_name clenv.evd) dep_mvs)));
clenv_pose_metas_as_evars clenv dep_mvs
(** Use our own fast path, more informative than from Typeclasses *)
@@ -140,7 +141,7 @@ let fail_quick_unif_flags = {
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_concl (Proofview.Goal.assume gl) in
+ let n = Tacmach.New.pf_concl gl in
let evd = clear_metas (Tacmach.New.project gl) in
try
let evd' = w_unify env evd CONV ~flags m n in
diff --git a/proofs/goal.mli b/proofs/goal.mli
index ad968cdfb..37dd9d3c0 100644
--- a/proofs/goal.mli
+++ b/proofs/goal.mli
@@ -58,7 +58,7 @@ module V82 : sig
(* Principal part of the progress tactical *)
val progress : goal list Evd.sigma -> goal Evd.sigma -> bool
-
+
(* Principal part of tclNOTSAMEGOAL *)
val same_goal : Evd.evar_map -> goal -> Evd.evar_map -> goal -> bool
diff --git a/proofs/logic.ml b/proofs/logic.ml
index a9ad606a0..5ff5fa38a 100644
--- a/proofs/logic.ml
+++ b/proofs/logic.ml
@@ -40,7 +40,7 @@ type refiner_error =
| DoesNotOccurIn of constr * Id.t
| NoSuchHyp of Id.t
-exception RefinerError of refiner_error
+exception RefinerError of Environ.env * Evd.evar_map * refiner_error
open Pretype_errors
@@ -69,7 +69,7 @@ let catchable_exception = function
| PretypeError(_,_, e) -> is_unification_error e || is_typing_error e
| _ -> false
-let error_no_such_hypothesis id = raise (RefinerError (NoSuchHyp id))
+let error_no_such_hypothesis env sigma id = raise (RefinerError (env, sigma, NoSuchHyp id))
(* Tells if the refiner should check that the submitted rules do not
produce invalid subgoals *)
@@ -78,10 +78,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 check sign id f =
+let apply_to_hyp env sigma 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 env sigma id
else sign
let check_typability env sigma c =
@@ -147,7 +147,7 @@ let reorder_context env sigma sign ord =
step ord' expected ctxt_head mh (d::ctxt_tail)
| _ ->
(match ctxt_head with
- | [] -> error_no_such_hypothesis (List.hd ord)
+ | [] -> error_no_such_hypothesis env sigma (List.hd ord)
| d :: ctxt ->
let x = NamedDecl.get_id d in
if Id.Set.mem x expected then
@@ -190,9 +190,9 @@ let move_location_eq m1 m2 = match m1, m2 with
| MoveFirst, MoveFirst -> true
| _ -> false
-let split_sign hfrom hto l =
+let split_sign env sigma hfrom hto l =
let rec splitrec left toleft = function
- | [] -> error_no_such_hypothesis hfrom
+ | [] -> error_no_such_hypothesis env sigma hfrom
| d :: right ->
let hyp = NamedDecl.get_id d in
if Id.equal hyp hfrom then
@@ -222,7 +222,7 @@ let move_hyp sigma toleft (left,declfrom,right) hto =
let rec moverec first middle = function
| [] ->
if match hto with MoveFirst | MoveLast -> false | _ -> true then
- error_no_such_hypothesis (hyp_of_move_location hto);
+ error_no_such_hypothesis env sigma (hyp_of_move_location hto);
List.rev first @ List.rev middle
| d :: _ as right when move_location_eq hto (MoveBefore (NamedDecl.get_id d)) ->
List.rev first @ List.rev middle @ right
@@ -258,10 +258,10 @@ let move_hyp sigma toleft (left,declfrom,right) hto =
List.fold_left (fun sign d -> push_named_context_val d sign)
right left
-let move_hyp_in_named_context sigma hfrom hto sign =
+let move_hyp_in_named_context env sigma hfrom hto sign =
let open EConstr in
let (left,right,declfrom,toleft) =
- split_sign hfrom hto (named_context_of_val sign) in
+ split_sign env sigma hfrom hto (named_context_of_val sign) in
move_hyp sigma toleft (left,declfrom,right) hto
let insert_decl_in_named_context sigma decl hto sign =
@@ -293,15 +293,15 @@ let collect_meta_variables c =
in
List.rev (collrec false [] c)
-let check_meta_variables c =
+let check_meta_variables env sigma c =
if not (List.distinct_f Int.compare (collect_meta_variables c)) then
- raise (RefinerError (NonLinearProof c))
+ raise (RefinerError (env, sigma, NonLinearProof c))
let check_conv_leq_goal env sigma arg ty conclty =
if !check then
let evm, b = Reductionops.infer_conv env sigma (EConstr.of_constr ty) (EConstr.of_constr conclty) in
if b then evm
- else raise (RefinerError (BadType (arg,ty,conclty)))
+ else raise (RefinerError (env, sigma, BadType (arg,ty,conclty)))
else sigma
exception Stop of EConstr.t list
@@ -334,9 +334,9 @@ let rec mk_refgoals sigma goal goalacc conclty trm =
else
match kind trm with
| Meta _ ->
- let conclty = nf_betaiota sigma (EConstr.of_constr conclty) in
+ let conclty = nf_betaiota env sigma (EConstr.of_constr conclty) in
if !check && occur_meta sigma conclty then
- raise (RefinerError (MetaInType conclty));
+ raise (RefinerError (env, sigma, MetaInType conclty));
let (gl,ev,sigma) = mk_goal hyps conclty in
let ev = EConstr.Unsafe.to_constr ev in
let conclty = EConstr.Unsafe.to_constr conclty in
@@ -416,7 +416,7 @@ and mk_hdgoals sigma goal goalacc trm =
match kind trm with
| Cast (c,_, ty) when isMeta c ->
check_typability env sigma ty;
- let (gl,ev,sigma) = mk_goal hyps (nf_betaiota sigma (EConstr.of_constr ty)) in
+ let (gl,ev,sigma) = mk_goal hyps (nf_betaiota env sigma (EConstr.of_constr ty)) in
let ev = EConstr.Unsafe.to_constr ev in
gl::goalacc,ty,sigma,ev
@@ -477,7 +477,9 @@ and mk_arggoals sigma goal goalacc funty allargs =
| Prod (_, c1, b) ->
let (acc, hargty, sigma, arg) = mk_refgoals sigma goal goalacc c1 harg in
(acc, subst1 harg b, sigma), arg
- | _ -> raise (RefinerError (CannotApply (t, harg)))
+ | _ ->
+ let env = Goal.V82.env sigma goal in
+ raise (RefinerError (env,sigma,CannotApply (t, harg)))
in
Array.smartfoldmap foldmap (goalacc, funty, sigma) allargs
@@ -497,10 +499,10 @@ and mk_casegoals sigma goal goalacc p c =
let convert_hyp check sign sigma d =
let id = NamedDecl.get_id d in
let b = NamedDecl.get_value d in
- let env = Global.env() in
+ let env = Global.env () in
let reorder = ref [] in
let sign' =
- apply_to_hyp check sign id
+ apply_to_hyp env sigma check sign id
(fun _ d' _ ->
let c = Option.map EConstr.of_constr (NamedDecl.get_value d') in
let env = Global.env_of_context sign in
@@ -514,19 +516,18 @@ let convert_hyp check sign sigma d =
map_named_decl EConstr.Unsafe.to_constr d) in
reorder_val_context env sigma sign' !reorder
-
-
(************************************************************************)
(************************************************************************)
(* Primitive tactics are handled here *)
let prim_refiner r sigma goal =
+ let env = Goal.V82.env sigma goal in
let cl = Goal.V82.concl sigma goal in
match r with
(* Logical rules *)
| Refine c ->
let cl = EConstr.Unsafe.to_constr cl in
- check_meta_variables c;
+ check_meta_variables env sigma c;
let (sgl,cl',sigma,oterm) = mk_refgoals sigma goal [] cl c in
let sgl = List.rev sgl in
let sigma = Goal.V82.partial_solution sigma goal (EConstr.of_constr oterm) in
diff --git a/proofs/logic.mli b/proofs/logic.mli
index 7df7fd66b..afd1ecf70 100644
--- a/proofs/logic.mli
+++ b/proofs/logic.mli
@@ -50,16 +50,16 @@ type refiner_error =
| DoesNotOccurIn of constr * Id.t
| NoSuchHyp of Id.t
-exception RefinerError of refiner_error
+exception RefinerError of Environ.env * evar_map * refiner_error
-val error_no_such_hypothesis : Id.t -> 'a
+val error_no_such_hypothesis : Environ.env -> evar_map -> Id.t -> 'a
val catchable_exception : exn -> bool
val convert_hyp : bool -> Environ.named_context_val -> evar_map ->
EConstr.named_declaration -> Environ.named_context_val
-val move_hyp_in_named_context : Evd.evar_map -> Id.t -> Id.t Misctypes.move_location ->
+val move_hyp_in_named_context : Environ.env -> Evd.evar_map -> Id.t -> Id.t Misctypes.move_location ->
Environ.named_context_val -> Environ.named_context_val
val insert_decl_in_named_context : Evd.evar_map ->
diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml
index c526ae000..6b503a011 100644
--- a/proofs/pfedit.ml
+++ b/proofs/pfedit.ml
@@ -140,7 +140,8 @@ 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
Proof_global.discard_current ();
- const, status, fst univs
+ let univs = UState.demote_seff_univs const univs in
+ const, status, univs
with reraise ->
let reraise = CErrors.push reraise in
Proof_global.discard_current ();
diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli
index d676a0874..5a317a956 100644
--- a/proofs/pfedit.mli
+++ b/proofs/pfedit.mli
@@ -35,11 +35,11 @@ val start_proof :
val cook_this_proof :
Proof_global.proof_object ->
(Id.t *
- (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * goal_kind))
+ (Safe_typing.private_constants Entries.definition_entry * UState.t * goal_kind))
val cook_proof : unit ->
(Id.t *
- (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * goal_kind))
+ (Safe_typing.private_constants Entries.definition_entry * UState.t * goal_kind))
(** {6 ... } *)
(** [get_goal_context n] returns the context of the [n]th subgoal of
@@ -74,7 +74,7 @@ val current_proof_statement :
val solve : ?with_end_tac:unit Proofview.tactic ->
Vernacexpr.goal_selector -> int option -> unit Proofview.tactic ->
- Proof.proof -> Proof.proof*bool
+ Proof.t -> Proof.t * bool
(** [by tac] applies tactic [tac] to the 1st subgoal of the current
focused proof or raises a UserError if there is no focused proof or
diff --git a/proofs/proof.ml b/proofs/proof.ml
index 413b5fdd7..04e707cd6 100644
--- a/proofs/proof.ml
+++ b/proofs/proof.ml
@@ -98,7 +98,7 @@ let done_cond ?(loose_end=false) k = CondDone (loose_end,k)
(* Subpart of the type of proofs. It contains the parts of the proof which
are under control of the undo mechanism *)
-type proof = {
+type t = {
(* Current focused proofview *)
proofview: Proofview.proofview;
(* Entry for the proofview *)
@@ -115,6 +115,8 @@ type proof = {
initial_euctx : UState.t
}
+type proof = t
+
(*** General proof functions ***)
let proof p =
diff --git a/proofs/proof.mli b/proofs/proof.mli
index 83777fc96..0b5e771ef 100644
--- a/proofs/proof.mli
+++ b/proofs/proof.mli
@@ -30,7 +30,9 @@
*)
(* Type of a proof. *)
-type proof
+type t
+type proof = t
+[@@ocaml.deprecated "please use [Proof.t]"]
(* Returns a stylised view of a proof for use by, for instance,
ide-s. *)
@@ -42,7 +44,7 @@ type proof
shelf (the list of goals on the shelf), a representation of the
given up goals (the list of the given up goals) and the underlying
evar_map *)
-val proof : proof ->
+val proof : t ->
Goal.goal list
* (Goal.goal list * Goal.goal list) list
* Goal.goal list
@@ -61,26 +63,26 @@ type 'a pre_goals = {
(** List of the goals that have been given up *)
}
-val map_structured_proof : proof -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre_goals)
+val map_structured_proof : t -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre_goals)
(*** General proof functions ***)
-val start : Evd.evar_map -> (Environ.env * EConstr.types) list -> proof
-val dependent_start : Proofview.telescope -> proof
-val initial_goals : proof -> (EConstr.constr * EConstr.types) list
-val initial_euctx : proof -> UState.t
+val start : Evd.evar_map -> (Environ.env * EConstr.types) list -> t
+val dependent_start : Proofview.telescope -> t
+val initial_goals : t -> (EConstr.constr * EConstr.types) list
+val initial_euctx : t -> UState.t
(* Returns [true] if the considered proof is completed, that is if no goal remain
to be considered (this does not require that all evars have been solved). *)
-val is_done : proof -> bool
+val is_done : t -> bool
(* Like is_done, but this time it really means done (i.e. nothing left to do) *)
-val is_complete : proof -> bool
+val is_complete : t -> bool
(* Returns the list of partial proofs to initial goals. *)
-val partial_proof : proof -> EConstr.constr list
+val partial_proof : t -> EConstr.constr list
-val compact : proof -> proof
+val compact : t -> t
(* Returns the proofs (with their type) of the initial goals.
Raises [UnfinishedProof] is some goals remain to be considered.
@@ -91,7 +93,7 @@ exception UnfinishedProof
exception HasShelvedGoals
exception HasGivenUpGoals
exception HasUnresolvedEvar
-val return : proof -> Evd.evar_map
+val return : t -> Evd.evar_map
(*** Focusing actions ***)
@@ -131,7 +133,7 @@ val done_cond : ?loose_end:bool -> 'a focus_kind -> 'a focus_condition
(* focus command (focuses on the [i]th subgoal) *)
(* spiwack: there could also, easily be a focus-on-a-range tactic, is there
a need for it? *)
-val focus : 'a focus_condition -> 'a -> int -> proof -> proof
+val focus : 'a focus_condition -> 'a -> int -> t -> t
exception FullyUnfocused
exception CannotUnfocusThisWay
@@ -147,59 +149,59 @@ exception NoSuchGoals of int * int
Raises [FullyUnfocused] if the proof is not focused.
Raises [CannotUnfocusThisWay] if the proof the unfocusing condition
is not met. *)
-val unfocus : 'a focus_kind -> proof -> unit -> proof
+val unfocus : 'a focus_kind -> t -> unit -> t
(* [unfocused p] returns [true] when [p] is fully unfocused. *)
-val unfocused : proof -> bool
+val unfocused : t -> bool
(* [get_at_focus k] gets the information stored at the closest focus point
of kind [k].
Raises [NoSuchFocus] if there is no focus point of kind [k]. *)
exception NoSuchFocus
-val get_at_focus : 'a focus_kind -> proof -> 'a
+val get_at_focus : 'a focus_kind -> t -> 'a
(* [is_last_focus k] check if the most recent focus is of kind [k] *)
-val is_last_focus : 'a focus_kind -> proof -> bool
+val is_last_focus : 'a focus_kind -> t -> bool
(* returns [true] if there is no goal under focus. *)
-val no_focused_goal : proof -> bool
+val no_focused_goal : t -> bool
(*** Tactics ***)
(* the returned boolean signal whether an unsafe tactic has been
used. In which case it is [false]. *)
val run_tactic : Environ.env ->
- unit Proofview.tactic -> proof -> proof*(bool*Proofview_monad.Info.tree)
+ unit Proofview.tactic -> t -> t * (bool*Proofview_monad.Info.tree)
-val maximal_unfocus : 'a focus_kind -> proof -> proof
+val maximal_unfocus : 'a focus_kind -> t -> t
(*** Commands ***)
-val in_proof : proof -> (Evd.evar_map -> 'a) -> 'a
+val in_proof : t -> (Evd.evar_map -> 'a) -> 'a
(* Remove all the goals from the shelf and adds them at the end of the
focused goals. *)
-val unshelve : proof -> proof
+val unshelve : t -> t
-val pr_proof : proof -> Pp.t
+val pr_proof : t -> Pp.t
(*** Compatibility layer with <=v8.2 ***)
module V82 : sig
- val subgoals : proof -> Goal.goal list Evd.sigma
+ val subgoals : t -> Goal.goal list Evd.sigma
[@@ocaml.deprecated "Use the first and fifth argument of [Proof.proof]"]
(* All the subgoals of the proof, including those which are not focused. *)
- val background_subgoals : proof -> Goal.goal list Evd.sigma
+ val background_subgoals : t -> Goal.goal list Evd.sigma
- val top_goal : proof -> Goal.goal Evd.sigma
+ val top_goal : t -> Goal.goal Evd.sigma
(* returns the existential variable used to start the proof *)
- val top_evars : proof -> Evar.t list
+ val top_evars : t -> Evar.t list
(* Turns the unresolved evars into goals.
Raises [UnfinishedProof] if there are still unsolved goals. *)
- val grab_evars : proof -> proof
+ val grab_evars : t -> t
(* Implements the Existential command *)
- val instantiate_evar : int -> Constrexpr.constr_expr -> proof -> proof
+ val instantiate_evar : int -> Constrexpr.constr_expr -> t -> t
end
diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml
index 4f575ab4b..214916331 100644
--- a/proofs/proof_bullet.ml
+++ b/proofs/proof_bullet.ml
@@ -25,8 +25,8 @@ let pr_bullet b =
type behavior = {
name : string;
- put : proof -> t -> proof;
- suggest: proof -> Pp.t
+ put : Proof.t -> t -> Proof.t;
+ suggest: Proof.t -> Pp.t
}
let behaviors = Hashtbl.create 4
@@ -110,7 +110,7 @@ module Strict = struct
let push (b:t) pr =
focus bullet_cond (b::get_bullets pr) 1 pr
- let suggest_bullet (prf : proof): suggestion =
+ let suggest_bullet (prf : Proof.t): suggestion =
if is_done prf then ProofFinished
else if not (no_focused_goal prf)
then (* No suggestion if a bullet is not mandatory, look for an unfinished bullet *)
@@ -137,7 +137,7 @@ module Strict = struct
in
loop prf
- let rec pop_until (prf : proof) bul : proof =
+ let rec pop_until (prf : Proof.t) bul : Proof.t =
let prf', b = pop prf in
if bullet_eq bul b then prf'
else pop_until prf' bul
diff --git a/proofs/proof_bullet.mli b/proofs/proof_bullet.mli
index 9e924fec9..09fcabf50 100644
--- a/proofs/proof_bullet.mli
+++ b/proofs/proof_bullet.mli
@@ -12,8 +12,6 @@
(* *)
(**********************************************************)
-open Proof
-
type t = Vernacexpr.bullet
(** A [behavior] is the data of a put function which
@@ -22,8 +20,8 @@ type t = Vernacexpr.bullet
with a name to identify the behavior. *)
type behavior = {
name : string;
- put : proof -> t -> proof;
- suggest: proof -> Pp.t
+ put : Proof.t -> t -> Proof.t;
+ suggest: Proof.t -> Pp.t
}
(** A registered behavior can then be accessed in Coq
@@ -39,8 +37,8 @@ val register_behavior : behavior -> unit
(** Handles focusing/defocusing with bullets:
*)
-val put : proof -> t -> proof
-val suggest : proof -> Pp.t
+val put : Proof.t -> t -> Proof.t
+val suggest : Proof.t -> Pp.t
(**********************************************************)
(* *)
diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml
index aa5621770..833e34c33 100644
--- a/proofs/proof_global.ml
+++ b/proofs/proof_global.ml
@@ -68,17 +68,16 @@ let _ =
(* Extra info on proofs. *)
type lemma_possible_guards = int list list
-type proof_universes = UState.t * Universes.universe_binders option
type proof_object = {
id : Names.Id.t;
entries : Safe_typing.private_constants Entries.definition_entry list;
persistence : Decl_kinds.goal_kind;
- universes: proof_universes;
+ universes: UState.t;
}
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 * UState.t
| Proved of Vernacexpr.opacity_flag *
Vernacexpr.lident option *
proof_object
@@ -90,12 +89,15 @@ type pstate = {
terminator : proof_terminator CEphemeron.key;
endline_tactic : Genarg.glob_generic_argument option;
section_vars : Context.Named.t option;
- proof : Proof.proof;
+ proof : Proof.t;
strength : Decl_kinds.goal_kind;
mode : proof_mode CEphemeron.key;
universe_decl: Univdecls.universe_decl;
}
+type t = pstate list
+type state = t
+
let make_terminator f = f
let apply_terminator f = f
@@ -144,6 +146,7 @@ let cur_pstate () =
| [] -> raise NoCurrentProof
let give_me_the_proof () = (cur_pstate ()).proof
+let give_me_the_proof_opt () = try Some (give_me_the_proof ()) with | NoCurrentProof -> None
let get_current_proof_name () = (cur_pstate ()).pid
let with_current_proof f =
@@ -330,7 +333,6 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now
in
let fpl, univs = Future.split2 fpl in
let universes = if poly || now then Future.force univs else initial_euctx in
- let binders = if poly then Some (UState.universe_binders universes) else None in
(* Because of dependent subgoals at the beginning of proofs, we could
have existential variables in the initial types of goals, we need to
normalise them for the kernel. *)
@@ -342,26 +344,21 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now
if poly || now then
let make_body t (c, eff) =
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 = Univops.universes_of_constr body in
- let used_univs_typ = Univops.universes_of_constr typ in
- (* Universes for private constants are relevant to the body *)
- let used_univs_body =
- List.fold_left (fun acc (us,_) -> Univ.LSet.union acc us)
- used_univs_body (Safe_typing.universes_of_private eff)
+ let allow_deferred =
+ not poly && (keep_body_ucst_separate ||
+ not (Safe_typing.empty_private_constants = eff))
in
- if keep_body_ucst_separate ||
- not (Safe_typing.empty_private_constants = eff) then
+ let typ = if allow_deferred then t else nf t in
+ let env = Global.env () in
+ let used_univs_body = Univops.universes_of_constr env body in
+ let used_univs_typ = Univops.universes_of_constr env typ in
+ if allow_deferred then
let initunivs = UState.const_univ_entry ~poly initial_euctx in
let ctx = constrain_variables 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 used_univs = Univ.LSet.union used_univs_body used_univs_typ in
+ let used_univs = Univ.LSet.union used_univs_body used_univs_typ in
let ctx_body = UState.restrict ctx used_univs in
let univs = UState.check_mono_univ_decl ctx_body universe_decl in
(initunivs, typ), ((body, univs), eff)
@@ -406,7 +403,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now
in
let entries = Future.map2 entry_fn fpl initial_goals in
{ id = pid; entries = entries; persistence = strength;
- universes = (universes, binders) },
+ universes },
fun pr_ending -> CEphemeron.get terminator pr_ending
let return_proof ?(allow_partial=false) () =
@@ -467,8 +464,6 @@ module V82 = struct
pid, (goals, strength)
end
-type state = pstate list
-
let freeze ~marshallable =
match marshallable with
| `Yes ->
@@ -491,7 +486,10 @@ let update_global_env () =
(* XXX: Bullet hook, should be really moved elsewhere *)
let _ =
let hook n =
- let prf = give_me_the_proof () in
- (Proof_bullet.suggest prf) in
+ try
+ let prf = give_me_the_proof () in
+ (Proof_bullet.suggest prf)
+ with NoCurrentProof -> mt ()
+ in
Proofview.set_nosuchgoals_hook hook
diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli
index eed62f912..29445a746 100644
--- a/proofs/proof_global.mli
+++ b/proofs/proof_global.mli
@@ -10,6 +10,10 @@
toplevel. In particular it defines the global proof
environment. *)
+type t
+type state = t
+[@@ocaml.deprecated "please use [Proof_global.t]"]
+
val there_are_pending_proofs : unit -> bool
val check_no_pending_proof : unit -> unit
@@ -20,8 +24,9 @@ val discard : Names.Id.t Loc.located -> unit
val discard_current : unit -> unit
val discard_all : unit -> unit
+val give_me_the_proof_opt : unit -> Proof.t option
exception NoCurrentProof
-val give_me_the_proof : unit -> Proof.proof
+val give_me_the_proof : unit -> Proof.t
(** @raise NoCurrentProof when outside proof mode. *)
val compact_the_proof : unit -> unit
@@ -33,18 +38,17 @@ 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 = UState.t * Universes.universe_binders option
type proof_object = {
id : Names.Id.t;
entries : Safe_typing.private_constants Entries.definition_entry list;
persistence : Decl_kinds.goal_kind;
- universes: proof_universes;
+ universes: UState.t;
}
type proof_ending =
| Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry *
- proof_universes
+ UState.t
| Proved of Vernacexpr.opacity_flag *
Vernacexpr.lident option *
proof_object
@@ -107,9 +111,9 @@ val get_open_goals : unit -> int
no current proof.
The return boolean is set to [false] if an unsafe tactic has been used. *)
val with_current_proof :
- (unit Proofview.tactic -> Proof.proof -> Proof.proof*'a) -> 'a
+ (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a
val simple_with_current_proof :
- (unit Proofview.tactic -> Proof.proof -> Proof.proof) -> unit
+ (unit Proofview.tactic -> Proof.t -> Proof.t) -> unit
(** Sets the tactic to be used when a tactic line is closed with [...] *)
val set_endline_tactic : Genarg.glob_generic_argument -> unit
@@ -129,11 +133,10 @@ module V82 : sig
Decl_kinds.goal_kind)
end
-type state
-val freeze : marshallable:[`Yes | `No | `Shallow] -> state
-val unfreeze : state -> unit
-val proof_of_state : state -> Proof.proof
-val copy_terminators : src:state -> tgt:state -> state
+val freeze : marshallable:[`Yes | `No | `Shallow] -> t
+val unfreeze : t -> unit
+val proof_of_state : t -> Proof.t
+val copy_terminators : src:t -> tgt:t -> t
(**********************************************************)
diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml
index 6052ba367..9a5d4e154 100644
--- a/proofs/redexpr.ml
+++ b/proofs/redexpr.ml
@@ -25,8 +25,11 @@ open Misctypes
(* call by value normalisation function using the virtual machine *)
let cbv_vm env sigma c =
- let ctyp = Retyping.get_type_of env sigma c in
- Vnorm.cbv_vm env sigma c ctyp
+ if Coq_config.bytecode_compiler then
+ let ctyp = Retyping.get_type_of env sigma c in
+ Vnorm.cbv_vm env sigma c ctyp
+ else
+ compute env sigma c
let warn_native_compute_disabled =
CWarnings.create ~name:"native-compute-disabled" ~category:"native-compiler"
@@ -34,12 +37,12 @@ let warn_native_compute_disabled =
strbrk "native_compute disabled at configure time; falling back to vm_compute.")
let cbv_native env sigma c =
- if Coq_config.no_native_compiler then
- (warn_native_compute_disabled ();
- cbv_vm env sigma c)
- else
+ if Coq_config.native_compiler then
let ctyp = Retyping.get_type_of env sigma c in
Nativenorm.native_norm env sigma c ctyp
+ else
+ (warn_native_compute_disabled ();
+ cbv_vm env sigma c)
let whd_cbn flags env sigma t =
let (state,_) =
diff --git a/proofs/refine.ml b/proofs/refine.ml
index e3f650848..90276951b 100644
--- a/proofs/refine.ml
+++ b/proofs/refine.ml
@@ -70,7 +70,6 @@ let add_side_effects env effects =
List.fold_left (fun env eff -> add_side_effect env eff) env effects
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
let concl = Proofview.Goal.concl gl in
@@ -159,7 +158,6 @@ let with_type env evd c t =
evd , j'.Environ.uj_val
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
let f h =
diff --git a/proofs/refine.mli b/proofs/refine.mli
index cfdcde36e..1932a306c 100644
--- a/proofs/refine.mli
+++ b/proofs/refine.mli
@@ -33,7 +33,7 @@ val refine_one : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * ('a * EConstr
(** A variant of [refine] which assumes exactly one goal under focus *)
val generic_refine : typecheck:bool -> ('a * EConstr.t) tactic ->
- [ `NF ] Proofview.Goal.t -> 'a tactic
+ Proofview.Goal.t -> 'a tactic
(** The general version of refine. *)
(** {7 Helper functions} *)
diff --git a/proofs/refiner.ml b/proofs/refiner.ml
index 3e3313eb5..cd2b10906 100644
--- a/proofs/refiner.ml
+++ b/proofs/refiner.ml
@@ -30,8 +30,8 @@ let refiner pr goal_sigma =
(* Profiling refiner *)
let refiner =
if Flags.profile then
- let refiner_key = Profile.declare_profile "refiner" in
- Profile.profile2 refiner_key refiner
+ let refiner_key = CProfile.declare_profile "refiner" in
+ CProfile.profile2 refiner_key refiner
else refiner
(*********************)
diff --git a/proofs/refiner.mli b/proofs/refiner.mli
index 34e517aed..52dc8bfd8 100644
--- a/proofs/refiner.mli
+++ b/proofs/refiner.mli
@@ -40,7 +40,7 @@ val tclEVARUNIVCONTEXT : UState.t -> tactic
val tclPUSHCONTEXT : Evd.rigid -> Univ.ContextSet.t -> tactic -> tactic
val tclPUSHEVARUNIVCONTEXT : UState.t -> tactic
-val tclPUSHCONSTRAINTS : Univ.constraints -> tactic
+val tclPUSHCONSTRAINTS : Univ.Constraint.t -> tactic
(** [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies
[tac2] to every resulting subgoals *)
diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml
index a8ec4d8ca..d3405b892 100644
--- a/proofs/tacmach.ml
+++ b/proofs/tacmach.ml
@@ -55,10 +55,11 @@ let pf_nth_hyp_id gls n = List.nth (pf_hyps gls) (n-1) |> NamedDecl.get_id
let pf_last_hyp gl = List.hd (pf_hyps gl)
let pf_get_hyp gls id =
+ let env, sigma = pf_env gls, project gls in
try
Context.Named.lookup id (pf_hyps gls)
with Not_found ->
- raise (RefinerError (NoSuchHyp id))
+ raise (RefinerError (env, sigma, NoSuchHyp id))
let pf_get_hyp_typ gls id =
id |> pf_get_hyp gls |> NamedDecl.get_type
@@ -86,7 +87,7 @@ let pf_e_reduce = pf_apply
let pf_whd_all = pf_reduce whd_all
let pf_hnf_constr = pf_reduce hnf_constr
let pf_nf = pf_reduce simpl
-let pf_nf_betaiota = pf_reduce (fun _ -> nf_betaiota)
+let pf_nf_betaiota = pf_reduce nf_betaiota
let pf_compute = pf_reduce compute
let pf_unfoldn ubinds = pf_reduce (unfoldn ubinds)
let pf_unsafe_type_of = pf_reduce unsafe_type_of
@@ -102,9 +103,6 @@ let pf_reduce_to_atomic_ind = pf_reduce reduce_to_atomic_ind
let pf_hnf_type_of gls = pf_get_type_of gls %> pf_whd_all gls
-let pf_is_matching gl p c = pf_apply Constr_matching.is_matching_conv gl p c
-let pf_matches gl p c = pf_apply Constr_matching.matches_conv gl p c
-
(********************************************)
(* Definition of the most primitive tactics *)
(********************************************)
@@ -152,7 +150,6 @@ module New = struct
let pf_global id gl =
(** We only check for the existence of an [id] in [hyps] *)
- let gl = Proofview.Goal.assume gl in
let hyps = Proofview.Goal.hyps gl in
Constrintern.construct_reference hyps id
@@ -169,13 +166,11 @@ module New = struct
let pf_ids_of_hyps gl =
(** We only get the identifiers in [hyps] *)
- let gl = Proofview.Goal.assume gl in
let hyps = Proofview.Goal.hyps gl in
ids_of_named_context hyps
let pf_ids_set_of_hyps gl =
(** We only get the identifiers in [hyps] *)
- let gl = Proofview.Goal.assume gl in
let env = Proofview.Goal.env gl in
Environ.ids_of_named_context_val (Environ.named_context_val env)
@@ -185,9 +180,10 @@ module New = struct
let pf_get_hyp id gl =
let hyps = Proofview.Goal.env gl in
+ let sigma = project gl in
let sign =
try EConstr.lookup_named id hyps
- with Not_found -> raise (RefinerError (NoSuchHyp id))
+ with Not_found -> raise (RefinerError (hyps, sigma, NoSuchHyp id))
in
sign
@@ -205,9 +201,8 @@ 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 : Proofview.Goal.t) =
(** We normalize the conclusion just after *)
- let gl = Proofview.Goal.assume gl in
let concl = Proofview.Goal.concl gl in
let sigma = project gl in
nf_evar sigma concl
@@ -223,8 +218,6 @@ module New = struct
let pf_hnf_type_of gl t =
pf_whd_all gl (pf_get_type_of gl t)
- let pf_matches gl pat t = pf_apply Constr_matching.matches_conv gl pat t
-
let pf_whd_all gl t = pf_apply whd_all gl t
let pf_compute gl t = pf_apply compute gl t
diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli
index d9496d2b4..8f69358d4 100644
--- a/proofs/tacmach.mli
+++ b/proofs/tacmach.mli
@@ -12,9 +12,7 @@ open Environ
open EConstr
open Proof_type
open Redexpr
-open Pattern
open Locus
-open Ltac_pretype
(** Operations for handling terms under a local typing context. *)
@@ -79,10 +77,6 @@ val pf_const_value : goal sigma -> pconstant -> constr
val pf_conv_x : goal sigma -> constr -> constr -> bool
val pf_conv_x_leq : goal sigma -> constr -> constr -> bool
-val pf_matches : goal sigma -> constr_pattern -> constr -> patvar_map
-val pf_is_matching : goal sigma -> constr_pattern -> constr -> bool
-
-
(** {6 The most primitive tactics. } *)
val refiner : rule -> tactic
@@ -98,48 +92,46 @@ val pr_glls : goal list sigma -> Pp.t
(* 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 : Id.t -> 'a Proofview.Goal.t -> Globnames.global_reference
+ val pf_apply : (env -> evar_map -> 'a) -> Proofview.Goal.t -> 'a
+ val pf_global : Id.t -> Proofview.Goal.t -> Globnames.global_reference
(** FIXME: encapsulate the level in an existential type. *)
- val of_old : (Proof_type.goal Evd.sigma -> 'a) -> [ `NF ] Proofview.Goal.t -> 'a
+ val of_old : (Proof_type.goal Evd.sigma -> 'a) -> Proofview.Goal.t -> 'a
- val project : 'a Proofview.Goal.t -> Evd.evar_map
- val pf_env : 'a Proofview.Goal.t -> Environ.env
- val pf_concl : 'a Proofview.Goal.t -> types
+ val project : Proofview.Goal.t -> Evd.evar_map
+ val pf_env : Proofview.Goal.t -> Environ.env
+ val pf_concl : Proofview.Goal.t -> types
(** WRONG: To be avoided at all costs, it typechecks the term entirely but
forgets the universe constraints necessary to retypecheck it *)
- val pf_unsafe_type_of : 'a Proofview.Goal.t -> constr -> types
+ val pf_unsafe_type_of : Proofview.Goal.t -> constr -> types
(** This function does no type inference and expects an already well-typed term.
It recomputes its type in the fastest way possible (no conversion is ever involved) *)
- val pf_get_type_of : 'a Proofview.Goal.t -> constr -> types
+ val pf_get_type_of : Proofview.Goal.t -> constr -> types
(** This function entirely type-checks the term and computes its type
and the implied universe constraints. *)
- val pf_type_of : 'a Proofview.Goal.t -> constr -> evar_map * types
- val pf_conv_x : 'a Proofview.Goal.t -> t -> t -> bool
-
- val pf_get_new_id : Id.t -> 'a Proofview.Goal.t -> Id.t
- val pf_ids_of_hyps : 'a Proofview.Goal.t -> Id.t list
- val pf_ids_set_of_hyps : 'a Proofview.Goal.t -> Id.Set.t
- val pf_hyps_types : 'a Proofview.Goal.t -> (Id.t * types) list
+ val pf_type_of : Proofview.Goal.t -> constr -> evar_map * types
+ val pf_conv_x : Proofview.Goal.t -> t -> t -> bool
- val pf_get_hyp : Id.t -> 'a Proofview.Goal.t -> named_declaration
- val pf_get_hyp_typ : Id.t -> 'a Proofview.Goal.t -> types
- val pf_last_hyp : 'a Proofview.Goal.t -> named_declaration
+ val pf_get_new_id : Id.t -> Proofview.Goal.t -> Id.t
+ val pf_ids_of_hyps : Proofview.Goal.t -> Id.t list
+ val pf_ids_set_of_hyps : Proofview.Goal.t -> Id.Set.t
+ val pf_hyps_types : Proofview.Goal.t -> (Id.t * types) list
- val pf_nf_concl : [ `LZ ] Proofview.Goal.t -> types
- val pf_reduce_to_quantified_ind : 'a Proofview.Goal.t -> types -> (inductive * EInstance.t) * types
+ val pf_get_hyp : Id.t -> Proofview.Goal.t -> named_declaration
+ val pf_get_hyp_typ : Id.t -> Proofview.Goal.t -> types
+ val pf_last_hyp : Proofview.Goal.t -> named_declaration
- val pf_hnf_constr : 'a Proofview.Goal.t -> constr -> types
- val pf_hnf_type_of : 'a Proofview.Goal.t -> constr -> types
+ val pf_nf_concl : Proofview.Goal.t -> types
+ val pf_reduce_to_quantified_ind : Proofview.Goal.t -> types -> (inductive * EInstance.t) * types
- val pf_whd_all : 'a Proofview.Goal.t -> constr -> constr
- val pf_compute : 'a Proofview.Goal.t -> constr -> constr
+ val pf_hnf_constr : Proofview.Goal.t -> constr -> types
+ val pf_hnf_type_of : Proofview.Goal.t -> constr -> types
- val pf_matches : 'a Proofview.Goal.t -> constr_pattern -> constr -> patvar_map
+ val pf_whd_all : Proofview.Goal.t -> constr -> constr
+ val pf_compute : Proofview.Goal.t -> constr -> constr
- val pf_nf_evar : 'a Proofview.Goal.t -> constr -> constr
+ val pf_nf_evar : Proofview.Goal.t -> constr -> constr
end
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-06 14:31:36 +0000