aboutsummaryrefslogtreecommitdiff
path: root/proofs
diff options
context:
space:
mode:
Diffstat (limited to 'proofs')
-rw-r--r--proofs/clenv.ml33
-rw-r--r--proofs/clenv.mli4
-rw-r--r--proofs/clenvtac.ml30
-rw-r--r--proofs/clenvtac.mli4
-rw-r--r--proofs/evar_refiner.ml12
-rw-r--r--proofs/goal.ml7
-rw-r--r--proofs/goal.mli4
-rw-r--r--proofs/logic.ml169
-rw-r--r--proofs/logic.mli5
-rw-r--r--proofs/pfedit.ml78
-rw-r--r--proofs/pfedit.mli22
-rw-r--r--proofs/proof.ml37
-rw-r--r--proofs/proof_global.ml77
-rw-r--r--proofs/proof_global.mli19
-rw-r--r--proofs/proof_type.mli32
-rw-r--r--proofs/proof_using.ml18
-rw-r--r--proofs/proof_using.mli2
-rw-r--r--proofs/proofs.mllib1
-rw-r--r--proofs/redexpr.ml36
-rw-r--r--proofs/redexpr.mli2
-rw-r--r--proofs/refine.ml62
-rw-r--r--proofs/refine.mli13
-rw-r--r--proofs/refiner.ml42
-rw-r--r--proofs/refiner.mli2
-rw-r--r--proofs/tacmach.ml40
-rw-r--r--proofs/tacmach.mli19
26 files changed, 407 insertions, 363 deletions
diff --git a/proofs/clenv.ml b/proofs/clenv.ml
index 1ef0b087ba..fad656223a 100644
--- a/proofs/clenv.ml
+++ b/proofs/clenv.ml
@@ -7,7 +7,7 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Nameops
@@ -72,7 +72,7 @@ let clenv_get_type_of ce c = Retyping.get_type_of (cl_env ce) (cl_sigma ce) c
exception NotExtensibleClause
let clenv_push_prod cl =
- let typ = whd_betadeltaiota (cl_env cl) (cl_sigma cl) (clenv_type cl) in
+ let typ = whd_all (cl_env cl) (cl_sigma cl) (clenv_type cl) in
let rec clrec typ = match kind_of_term typ with
| Cast (t,_,_) -> clrec t
| Prod (na,t,u) ->
@@ -109,7 +109,7 @@ let clenv_environments evd bound t =
| (n, Cast (t,_,_)) -> clrec (e,metas) n t
| (n, Prod (na,t1,t2)) ->
let mv = new_meta () in
- let dep = dependent (mkRel 1) t2 in
+ let dep = not (noccurn 1 t2) in
let na' = if dep then na else Anonymous in
let e' = meta_declare mv t1 ~name:na' e in
clrec (e', (mkMeta mv)::metas) (Option.map ((+) (-1)) n)
@@ -155,7 +155,7 @@ let error_incompatible_inst clenv mv =
let na = meta_name clenv.evd mv in
match na with
Name id ->
- errorlabstrm "clenv_assign"
+ user_err ~hdr:"clenv_assign"
(str "An incompatible instantiation has already been found for " ++
pr_id id)
| _ ->
@@ -417,11 +417,11 @@ let qhyp_eq h1 h2 = match h1, h2 with
let check_bindings bl =
match List.duplicates qhyp_eq (List.map pi2 bl) with
| NamedHyp s :: _ ->
- errorlabstrm ""
+ user_err
(str "The variable " ++ pr_id s ++
str " occurs more than once in binding list.");
| AnonHyp n :: _ ->
- errorlabstrm ""
+ user_err
(str "The position " ++ int n ++
str " occurs more than once in binding list.")
| [] -> ()
@@ -435,7 +435,7 @@ let explain_no_such_bound_variable evd id =
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"
+ user_err ~hdr:"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
@@ -460,7 +460,7 @@ let meta_with_name evd id =
| ([n],_|_,[n]) ->
n
| _ ->
- errorlabstrm "Evd.meta_with_name"
+ user_err ~hdr:"Evd.meta_with_name"
(str "Binder name \"" ++ pr_id id ++
strbrk "\" occurs more than once in clause.")
@@ -469,12 +469,12 @@ let meta_of_binder clause loc mvs = function
| AnonHyp n ->
try List.nth mvs (n-1)
with (Failure _|Invalid_argument _) ->
- errorlabstrm "" (str "No such binder.")
+ user_err (str "No such binder.")
let error_already_defined b =
match b with
| NamedHyp id ->
- errorlabstrm ""
+ user_err
(str "Binder name \"" ++ pr_id id ++
str"\" already defined with incompatible value.")
| AnonHyp n ->
@@ -491,7 +491,8 @@ let clenv_unify_binding_type clenv c t u =
let evd,c = w_coerce_to_type (cl_env clenv) clenv.evd c t u in
TypeProcessed, { clenv with evd = evd }, c
with
- | PretypeError (_,_,ActualTypeNotCoercible (_,_,NotClean _)) as e ->
+ | PretypeError (_,_,ActualTypeNotCoercible (_,_,
+ (NotClean _ | ConversionFailed _))) as e ->
raise e
| e when precatchable_exception e ->
TypeNotProcessed, clenv, c
@@ -526,7 +527,7 @@ let clenv_constrain_last_binding c clenv =
clenv_assign_binding clenv k c
let error_not_right_number_missing_arguments n =
- errorlabstrm ""
+ user_err
(strbrk "Not the right number of missing arguments (expected " ++
int n ++ str ").")
@@ -640,7 +641,7 @@ let explain_no_such_bound_variable holes id =
| [id] -> str "(possible name is: " ++ pr_id id ++ str ")."
| _ -> str "(possible names are: " ++ pr_enum pr_id mvl ++ str ")."
in
- errorlabstrm "" (str "No such bound variable " ++ pr_id id ++ expl)
+ user_err (str "No such bound variable " ++ pr_id id ++ expl)
let evar_with_name holes id =
let map h = match h.hole_name with
@@ -652,7 +653,7 @@ let evar_with_name holes id =
| [] -> explain_no_such_bound_variable holes id
| [h] -> h.hole_evar
| _ ->
- errorlabstrm ""
+ user_err
(str "Binder name \"" ++ pr_id id ++
str "\" occurs more than once in clause.")
@@ -662,8 +663,8 @@ let evar_of_binder holes = function
try
let h = List.nth holes (pred n) in
h.hole_evar
- with e when Errors.noncritical e ->
- errorlabstrm "" (str "No such binder.")
+ with e when CErrors.noncritical e ->
+ user_err (str "No such binder.")
let define_with_type sigma env ev c =
let t = Retyping.get_type_of env sigma ev in
diff --git a/proofs/clenv.mli b/proofs/clenv.mli
index 59b166ea01..e9236b1da3 100644
--- a/proofs/clenv.mli
+++ b/proofs/clenv.mli
@@ -6,6 +6,10 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(** This file defines clausenv, which is a deprecated way to handle open terms
+ in the proof engine. Most of the API here is legacy except for the
+ evar-based clauses. *)
+
open Names
open Term
open Environ
diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml
index 08e6c91de6..98b5bc8b05 100644
--- a/proofs/clenvtac.ml
+++ b/proofs/clenvtac.ml
@@ -59,6 +59,19 @@ let clenv_pose_dependent_evars with_evars clenv =
(RefinerError (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 *)
+let check_tc evd =
+ let has_resolvable = ref false in
+ let check _ evi =
+ let res = Typeclasses.is_resolvable evi in
+ if res then
+ let () = has_resolvable := true in
+ Typeclasses.is_class_evar evd evi
+ else false
+ in
+ let has_typeclass = Evar.Map.exists check (Evd.undefined_map evd) in
+ (has_typeclass, !has_resolvable)
+
let clenv_refine with_evars ?(with_classes=true) clenv =
(** ppedrot: a Goal.enter here breaks things, because the tactic below may
solve goals by side effects, while the compatibility layer keeps those
@@ -67,9 +80,16 @@ let clenv_refine with_evars ?(with_classes=true) clenv =
let clenv = clenv_pose_dependent_evars with_evars clenv in
let evd' =
if with_classes then
- let evd' = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars
- ~fail:(not with_evars) clenv.env clenv.evd
- in Typeclasses.mark_unresolvables ~filter:Typeclasses.all_goals evd'
+ let (has_typeclass, has_resolvable) = check_tc clenv.evd in
+ let evd' =
+ if has_typeclass then
+ Typeclasses.resolve_typeclasses ~fast_path:false ~filter:Typeclasses.all_evars
+ ~fail:(not with_evars) clenv.env clenv.evd
+ else clenv.evd
+ in
+ if has_resolvable then
+ Typeclasses.mark_unresolvables ~filter:Typeclasses.all_goals evd'
+ else evd'
else clenv.evd
in
let clenv = { clenv with evd = evd' } in
@@ -120,10 +140,10 @@ let fail_quick_unif_flags = {
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 n = Tacmach.New.pf_concl (Proofview.Goal.assume 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'
- with e when Errors.noncritical e -> Proofview.tclZERO e
+ with e when CErrors.noncritical e -> Proofview.tclZERO e
end }
diff --git a/proofs/clenvtac.mli b/proofs/clenvtac.mli
index 00e74a2478..8a096b6457 100644
--- a/proofs/clenvtac.mli
+++ b/proofs/clenvtac.mli
@@ -6,10 +6,12 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(** Legacy components of the previous proof engine. *)
+
open Term
open Clenv
-open Tacexpr
open Unification
+open Misctypes
(** Tactics *)
val unify : ?flags:unify_flags -> constr -> unit Proofview.tactic
diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml
index 3192a6a29a..509efbc5b8 100644
--- a/proofs/evar_refiner.ml
+++ b/proofs/evar_refiner.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Names
open Evd
@@ -46,16 +46,16 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma =
let sigma',typed_c =
let flags = {
Pretyping.use_typeclasses = true;
- Pretyping.use_unif_heuristics = true;
+ Pretyping.solve_unification_constraints = true;
Pretyping.use_hook = None;
Pretyping.fail_evar = false;
Pretyping.expand_evars = true } in
try Pretyping.understand_ltac flags
env sigma ltac_var (Pretyping.OfType evi.evar_concl) rawc
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
let loc = Glob_ops.loc_of_glob_constr rawc in
- user_err_loc
- (loc,"", str "Instance is not well-typed in the environment of " ++
- str (string_of_existential evk))
+ user_err ~loc
+ (str "Instance is not well-typed in the environment of " ++
+ pr_existential_key sigma evk ++ str ".")
in
define_and_solve_constraints evk typed_c env (evars_reset_evd sigma' sigma)
diff --git a/proofs/goal.ml b/proofs/goal.ml
index 111a947a9c..a141708c2b 100644
--- a/proofs/goal.ml
+++ b/proofs/goal.ml
@@ -10,7 +10,8 @@ open Util
open Pp
open Term
open Sigma.Notations
-open Context.Named.Declaration
+
+module NamedDecl = Context.Named.Declaration
(* This module implements the abstract interface to goals *)
(* A general invariant of the module, is that a goal whose associated
@@ -77,7 +78,7 @@ module V82 = struct
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 (mkVar % get_id) ctxt in
+ let inst = Array.map_of_list (NamedDecl.get_id %> mkVar) ctxt in
let ev = Term.mkEvar (evk,inst) in
(evk, ev, evars)
@@ -148,7 +149,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 (get_id decl) genv); false
+ try ignore (Environ.lookup_named (NamedDecl.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/goal.mli b/proofs/goal.mli
index 8a3d6e815a..6a79c1f451 100644
--- a/proofs/goal.mli
+++ b/proofs/goal.mli
@@ -6,7 +6,9 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* This module implements the abstract interface to goals *)
+(** This module implements the abstract interface to goals. Most of the code
+ here is useless and should be eventually removed. Consider using
+ {!Proofview.Goal} instead. *)
type goal = Evar.t
diff --git a/proofs/logic.ml b/proofs/logic.ml
index 09f308abef..44c6294841 100644
--- a/proofs/logic.ml
+++ b/proofs/logic.ml
@@ -7,7 +7,7 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Nameops
@@ -24,6 +24,8 @@ open Retyping
open Misctypes
open Context.Named.Declaration
+module NamedDecl = Context.Named.Declaration
+
type refiner_error =
(* Errors raised by the refiner *)
@@ -59,7 +61,7 @@ let is_unification_error = function
| _ -> false
let catchable_exception = function
- | Errors.UserError _ | TypeError _
+ | CErrors.UserError _ | TypeError _
| RefinerError _ | Indrec.RecursionSchemeError _
| Nametab.GlobalizationError _
(* reduction errors *)
@@ -77,10 +79,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 =
@@ -151,7 +153,7 @@ let reorder_context env sign ord =
| top::ord' when mem_q top moved_hyps ->
let ((d,h),mh) = find_q top moved_hyps in
if occur_vars_in_decl env h d then
- errorlabstrm "reorder_context"
+ user_err ~hdr:"reorder_context"
(str "Cannot move declaration " ++ pr_id top ++ spc() ++
str "before " ++
pr_sequence pr_id
@@ -162,7 +164,7 @@ let reorder_context env sign ord =
(match ctxt_head with
| [] -> error_no_such_hypothesis (List.hd ord)
| d :: ctxt ->
- let x = get_id d in
+ let x = NamedDecl.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
@@ -178,11 +180,11 @@ let reorder_val_context env sign ord =
let check_decl_position env sign d =
- let x = get_id d in
+ let x = NamedDecl.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
- errorlabstrm "Logic.check_decl_position"
+ user_err ~hdr:"Logic.check_decl_position"
(str "Cannot create self-referring hypothesis " ++ pr_id x);
x::deps
@@ -204,8 +206,8 @@ let move_location_eq m1 m2 = match m1, m2 with
let rec get_hyp_after h = function
| [] -> error_no_such_hypothesis h
| d :: right ->
- if Id.equal (get_id d) h then
- match right with d' ::_ -> MoveBefore (get_id d') | [] -> MoveFirst
+ if Id.equal (NamedDecl.get_id d) h then
+ match right with d' ::_ -> MoveBefore (NamedDecl.get_id d') | [] -> MoveFirst
else
get_hyp_after h right
@@ -213,7 +215,7 @@ let split_sign hfrom hto l =
let rec splitrec left toleft = function
| [] -> error_no_such_hypothesis hfrom
| d :: right ->
- let hyp,_,typ = to_tuple d in
+ let hyp = NamedDecl.get_id d in
if Id.equal hyp hfrom then
(left,right,d, toleft || move_location_eq hto MoveLast)
else
@@ -235,24 +237,24 @@ let move_hyp toleft (left,declfrom,right) hto =
let env = Global.env() in
let test_dep d d2 =
if toleft
- then occur_var_in_decl env (get_id d2) d
- else occur_var_in_decl env (get_id d) d2
+ then occur_var_in_decl env (NamedDecl.get_id d2) d
+ else occur_var_in_decl env (NamedDecl.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
- | d :: _ as right when move_location_eq hto (MoveBefore (get_id d)) ->
+ | d :: _ as right when move_location_eq hto (MoveBefore (NamedDecl.get_id d)) ->
List.rev first @ List.rev middle @ right
| d :: right ->
- let hyp = get_id d in
+ let hyp = NamedDecl.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 (get_id declfrom) ++
+ 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 ")
++ pr_id hyp ++ str ".")
@@ -276,6 +278,11 @@ let move_hyp 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 hfrom hto sign =
+ let (left,right,declfrom,toleft) =
+ split_sign hfrom hto (named_context_of_val sign) in
+ move_hyp toleft (left,declfrom,right) hto
+
(**********************************************************************)
@@ -287,7 +294,7 @@ let move_hyp toleft (left,declfrom,right) hto =
variables only in Application and Case *)
let error_unsupported_deep_meta c =
- errorlabstrm "" (strbrk "Application of lemmas whose beta-iota normal " ++
+ user_err (strbrk "Application of lemmas whose beta-iota normal " ++
strbrk "form contains metavariables deep inside the term is not " ++
strbrk "supported; try \"refine\" instead.")
@@ -295,9 +302,9 @@ let collect_meta_variables c =
let rec collrec deep acc c = match kind_of_term c with
| Meta mv -> if deep then error_unsupported_deep_meta () else mv::acc
| Cast(c,_,_) -> collrec deep acc c
- | (App _| Case _) -> fold_constr (collrec deep) acc c
+ | (App _| Case _) -> Term.fold_constr (collrec deep) acc c
| Proj (_, c) -> collrec deep acc c
- | _ -> fold_constr (collrec true) acc c
+ | _ -> Term.fold_constr (collrec true) acc c
in
List.rev (collrec false [] c)
@@ -463,7 +470,7 @@ and mk_hdgoals sigma goal goalacc trm =
and mk_arggoals sigma goal goalacc funty allargs =
let foldmap (goalacc, funty, sigma) harg =
- let t = whd_betadeltaiota (Goal.V82.env sigma goal) sigma funty in
+ let t = whd_all (Goal.V82.env sigma goal) sigma funty in
let rec collapse t = match kind_of_term t with
| LetIn (_, c1, _, b) -> collapse (subst1 c1 b)
| _ -> t
@@ -489,19 +496,20 @@ and mk_casegoals sigma goal goalacc p c =
let convert_hyp check sign sigma d =
- let id,b,bt = to_tuple d in
+ let id = NamedDecl.get_id d in
+ let b = NamedDecl.get_value d in
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 c = NamedDecl.get_value d' in
let env = Global.env_of_context sign in
- if check && not (is_conv env sigma bt ct) then
- errorlabstrm "Logic.convert_hyp"
+ if check && not (is_conv env sigma (NamedDecl.get_type d) (NamedDecl.get_type d')) then
+ user_err ~hdr:"Logic.convert_hyp"
(str "Incorrect change of the type of " ++ pr_id id ++ str ".");
if check && not (Option.equal (is_conv env sigma) b c) then
- errorlabstrm "Logic.convert_hyp"
+ user_err ~hdr:"Logic.convert_hyp"
(str "Incorrect change of the body of "++ pr_id id ++ str ".");
if check then reorder := check_decl_position env sign d;
d) in
@@ -533,8 +541,8 @@ let prim_refiner r sigma goal =
nexthyp,
t,cl,sigma
else
- (if !check && mem_named_context id (named_context_of_val sign) then
- errorlabstrm "Logic.prim_refiner"
+ (if !check && mem_named_context_val id sign then
+ user_err ~hdr:"Logic.prim_refiner"
(str "Variable " ++ pr_id id ++ str " is already declared.");
push_named_context_val (LocalAssum (id,t)) sign,t,cl,sigma) in
let (sg2,ev2,sigma) =
@@ -543,114 +551,9 @@ 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
let sgl = List.rev sgl in
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
- let hyps' =
- move_hyp toleft (left,declfrom,right) hto in
- let (gl,ev,sigma) = mk_goal hyps' cl in
- let sigma = Goal.V82.partial_solution_to sigma goal gl ev in
- ([gl], sigma)
diff --git a/proofs/logic.mli b/proofs/logic.mli
index 9aa4ac2074..0dba9ef1ee 100644
--- a/proofs/logic.mli
+++ b/proofs/logic.mli
@@ -6,6 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(** Legacy proof engine. Do not use in newly written code. *)
+
open Names
open Term
open Evd
@@ -54,3 +56,6 @@ val catchable_exception : exn -> bool
val convert_hyp : bool -> Environ.named_context_val -> evar_map ->
Context.Named.Declaration.t -> Environ.named_context_val
+
+val move_hyp_in_named_context : Id.t -> Id.t Misctypes.move_location ->
+ Environ.named_context_val -> Environ.named_context_val
diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml
index 5367a907e5..80bea0c3b1 100644
--- a/proofs/pfedit.ml
+++ b/proofs/pfedit.ml
@@ -13,6 +13,17 @@ open Entries
open Environ
open Evd
+let use_unification_heuristics_ref = ref true
+let _ = Goptions.declare_bool_option {
+ Goptions.optsync = true; Goptions.optdepr = false;
+ Goptions.optname = "Solve unification constraints at every \".\"";
+ Goptions.optkey = ["Solve";"Unification";"Constraints"];
+ Goptions.optread = (fun () -> !use_unification_heuristics_ref);
+ Goptions.optwrite = (fun a -> use_unification_heuristics_ref:=a);
+}
+
+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
@@ -39,7 +50,7 @@ let cook_this_proof p =
match p with
| { Proof_global.id;entries=[constr];persistence;universes } ->
(id,(constr,universes,persistence))
- | _ -> Errors.anomaly ~label:"Pfedit.cook_proof" (Pp.str "more than one proof term.")
+ | _ -> CErrors.anomaly ~label:"Pfedit.cook_proof" (Pp.str "more than one proof term.")
let cook_proof () =
cook_this_proof (fst
@@ -59,9 +70,9 @@ let get_universe_binders () =
Proof_global.get_universe_binders ()
exception NoSuchGoal
-let _ = Errors.register_handler begin function
- | NoSuchGoal -> Errors.error "No such goal."
- | _ -> raise Errors.Unhandled
+let _ = CErrors.register_handler begin function
+ | NoSuchGoal -> CErrors.error "No such goal."
+ | _ -> raise CErrors.Unhandled
end
let get_nth_V82_goal i =
let p = Proof_global.give_me_the_proof () in
@@ -71,27 +82,38 @@ 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 -> CErrors.error "No focused proof."
+ | NoSuchGoal -> CErrors.error "No such goal."
let get_current_goal_context () =
try get_goal_context_gen 1
- with NoSuchGoal ->
+ with Proof_global.NoCurrentProof -> CErrors.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
- | _ -> Errors.anomaly ~label:"Pfedit.current_proof_statement" (Pp.str "more than one statement")
+ | _ -> CErrors.anomaly ~label:"Pfedit.current_proof_statement" (Pp.str "more than one statement")
let solve ?with_end_tac gi info_lvl tac pr =
try
@@ -104,22 +126,28 @@ let solve ?with_end_tac gi info_lvl tac pr =
in
let tac = match gi with
| Vernacexpr.SelectNth i -> Proofview.tclFOCUS i i tac
+ | Vernacexpr.SelectList l -> Proofview.tclFOCUSLIST l tac
| Vernacexpr.SelectId id -> Proofview.tclFOCUSID id tac
| Vernacexpr.SelectAll -> tac
in
+ let tac =
+ if use_unification_heuristics () then
+ Proofview.tclTHEN tac Refine.solve_constraints
+ else tac
+ in
let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac pr in
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
- | Proof_global.NoCurrentProof -> Errors.error "No focused proof"
+ | Proof_global.NoCurrentProof -> CErrors.error "No focused proof"
| CList.IndexOutOfRange ->
match gi with
| Vernacexpr.SelectNth i -> let msg = str "No such goal: " ++ int i ++ str "." in
- Errors.errorlabstrm "" msg
+ CErrors.user_err msg
| _ -> assert false
let by tac = Proof_global.with_current_proof (fun _ -> solve (Vernacexpr.SelectNth 1) None tac)
@@ -145,15 +173,16 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo
delete_current_proof ();
const, status, fst univs
with reraise ->
- let reraise = Errors.push reraise in
+ let reraise = CErrors.push reraise in
delete_current_proof ();
iraise reraise
-let build_by_tactic ?(side_eff=true) env ctx ?(poly=false) typ tac =
+let build_by_tactic ?(side_eff=true) env sigma ?(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, status, univs =
+ build_constant_by_tactic id sigma sign ~goal_kind:gk typ tac in
let ce =
if side_eff then Safe_typing.inline_private_constants_in_definition_entry env ce
else { ce with
@@ -176,7 +205,7 @@ let refine_by_tactic env sigma ty tac =
try Proof.run_tactic env tac prf
with Logic_monad.TacticFailure e as src ->
(** Catch the inner error of the monad tactic *)
- let (_, info) = Errors.push src in
+ let (_, info) = CErrors.push src in
iraise (e, info)
in
(** Plug back the retrieved sigma *)
@@ -203,7 +232,7 @@ let refine_by_tactic env sigma ty tac =
(* Support for resolution of evars in tactic interpretation, including
resolution by application of tactics *)
-let implicit_tactic = ref None
+let implicit_tactic = Summary.ref None ~name:"implicit-tactic"
let declare_implicit_tactic tac = implicit_tactic := Some tac
@@ -216,10 +245,13 @@ let solve_by_implicit_tactic env sigma evk =
when
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
+ let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (CErrors.UserError (None,Pp.str"Proof is not complete."))) []) in
(try
- let (ans, _, _) =
- build_by_tactic env (Evd.evar_universe_context sigma) evi.evar_concl tac in
- ans
+ let c = Evarutil.nf_evars_universes sigma evi.evar_concl in
+ if Evarutil.has_undefined_evars sigma c then raise Exit;
+ let (ans, _, ctx) =
+ build_by_tactic env (Evd.evar_universe_context sigma) c tac in
+ let sigma = Evd.set_universe_context sigma ctx in
+ sigma, ans
with e when Logic.catchable_exception e -> raise Exit)
| _ -> raise Exit
diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli
index cd89920151..7458109fa1 100644
--- a/proofs/pfedit.mli
+++ b/proofs/pfedit.mli
@@ -6,6 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(** Global proof state. A quite redundant wrapper on {!Proof_global}. *)
+
open Loc
open Names
open Term
@@ -93,6 +95,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 :
@@ -114,14 +124,14 @@ val get_all_proof_names : unit -> Id.t list
(** [set_end_tac tac] applies tactic [tac] to all subgoal generate
by [solve] *)
-val set_end_tac : Tacexpr.raw_tactic_expr -> unit
+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.section_context * (Loc.t * Names.Id.t) list
-val get_used_variables : unit -> Context.section_context option
+ Id.t list -> Context.Named.t * (Loc.t * Names.Id.t) list
+val get_used_variables : unit -> Context.Named.t option
(** {6 Universe binders } *)
val get_universe_binders : unit -> universe_binders option
@@ -157,7 +167,8 @@ 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 ->
- Safe_typing.private_constants 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 ->
@@ -179,5 +190,4 @@ val declare_implicit_tactic : unit Proofview.tactic -> unit
val clear_implicit_tactic : unit -> unit
(* Raise Exit if cannot solve *)
-(* FIXME: interface: it may incur some new universes etc... *)
-val solve_by_implicit_tactic : env -> Evd.evar_map -> Evd.evar -> constr
+val solve_by_implicit_tactic : env -> Evd.evar_map -> Evd.evar -> Evd.evar_map * constr
diff --git a/proofs/proof.ml b/proofs/proof.ml
index 86af420dc4..0a3b08c04a 100644
--- a/proofs/proof.ml
+++ b/proofs/proof.ml
@@ -64,17 +64,17 @@ exception NoSuchGoals of int * int
exception FullyUnfocused
-let _ = Errors.register_handler begin function
+let _ = CErrors.register_handler begin function
| CannotUnfocusThisWay ->
- Errors.error "This proof is focused, but cannot be unfocused this way"
+ CErrors.error "This proof is focused, but cannot be unfocused this way"
| NoSuchGoals (i,j) when Int.equal i j ->
- Errors.errorlabstrm "Focus" Pp.(str"No such goal (" ++ int i ++ str").")
+ CErrors.user_err ~hdr:"Focus" Pp.(str"No such goal (" ++ int i ++ str").")
| NoSuchGoals (i,j) ->
- Errors.errorlabstrm "Focus" Pp.(
+ CErrors.user_err ~hdr:"Focus" Pp.(
str"Not every goal in range ["++ int i ++ str","++int j++str"] exist."
)
- | FullyUnfocused -> Errors.error "The proof is not focused"
- | _ -> raise Errors.Unhandled
+ | FullyUnfocused -> CErrors.error "The proof is not focused"
+ | _ -> raise CErrors.Unhandled
end
let check_cond_kind c k =
@@ -300,12 +300,12 @@ exception UnfinishedProof
exception HasShelvedGoals
exception HasGivenUpGoals
exception HasUnresolvedEvar
-let _ = Errors.register_handler begin function
- | UnfinishedProof -> Errors.error "Some goals have not been solved."
- | HasShelvedGoals -> Errors.error "Some goals have been left on the shelf."
- | HasGivenUpGoals -> Errors.error "Some goals have been given up."
- | HasUnresolvedEvar -> Errors.error "Some existential variables are uninstantiated."
- | _ -> raise Errors.Unhandled
+let _ = CErrors.register_handler begin function
+ | UnfinishedProof -> CErrors.error "Some goals have not been solved."
+ | HasShelvedGoals -> CErrors.error "Some goals have been left on the shelf."
+ | HasGivenUpGoals -> CErrors.error "Some goals have been given up."
+ | HasUnresolvedEvar -> CErrors.error "Some existential variables are uninstantiated."
+ | _ -> raise CErrors.Unhandled
end
let return p =
@@ -351,7 +351,14 @@ let run_tactic env tac pr =
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 to_shelve = undef sigma to_shelve in
+ let shelf = (undef sigma pr.shelf)@retrieved@to_shelve in
+ let proofview =
+ List.fold_left
+ Proofview.Unsafe.mark_as_unresolvable
+ proofview
+ 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)
@@ -397,9 +404,9 @@ module V82 = struct
let evl = Evarutil.non_instantiated sigma in
let evl = Evar.Map.bindings evl in
if (n <= 0) then
- Errors.error "incorrect existential variable index"
+ CErrors.error "incorrect existential variable index"
else if CList.length evl < n then
- Errors.error "not so many uninstantiated existential variables"
+ CErrors.error "not so many uninstantiated existential variables"
else
CList.nth evl (n-1)
in
diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml
index 647dbe1115..a2ee622215 100644
--- a/proofs/proof_global.ml
+++ b/proofs/proof_global.ml
@@ -18,13 +18,16 @@ open Util
open Pp
open Names
+module NamedDecl = Context.Named.Declaration
+
(*** Proof Modes ***)
(* Type of proof modes :
- A function [set] to set it *from standard mode*
- A function [reset] to reset the *standard mode* from it *)
+type proof_mode_name = string
type proof_mode = {
- name : string ;
+ name : proof_mode_name ;
set : unit -> unit ;
reset : unit -> unit
}
@@ -33,7 +36,7 @@ let proof_modes = Hashtbl.create 6
let find_proof_mode n =
try Hashtbl.find proof_modes n
with Not_found ->
- Errors.error (Format.sprintf "No proof mode named \"%s\"." n)
+ CErrors.error (Format.sprintf "No proof mode named \"%s\"." n)
let register_proof_mode ({name = n} as m) =
Hashtbl.add proof_modes n (CEphemeron.create m)
@@ -45,6 +48,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 ;
@@ -84,8 +90,8 @@ type closed_proof = proof_object * proof_terminator
type pstate = {
pid : Id.t;
terminator : proof_terminator CEphemeron.key;
- endline_tactic : Tacexpr.raw_tactic_expr option;
- section_vars : Context.section_context option;
+ endline_tactic : Genarg.glob_generic_argument option;
+ section_vars : Context.Named.t option;
proof : Proof.proof;
strength : Decl_kinds.goal_kind;
mode : proof_mode CEphemeron.key;
@@ -118,15 +124,15 @@ let push a l = l := a::!l;
update_proof_mode ()
exception NoSuchProof
-let _ = Errors.register_handler begin function
- | NoSuchProof -> Errors.error "No such proof."
- | _ -> raise Errors.Unhandled
+let _ = CErrors.register_handler begin function
+ | NoSuchProof -> CErrors.error "No such proof."
+ | _ -> raise CErrors.Unhandled
end
exception NoCurrentProof
-let _ = Errors.register_handler begin function
- | NoCurrentProof -> Errors.error "No focused proof (No proof-editing in progress)."
- | _ -> raise Errors.Unhandled
+let _ = CErrors.register_handler begin function
+ | NoCurrentProof -> CErrors.error "No focused proof (No proof-editing in progress)."
+ | _ -> raise CErrors.Unhandled
end
(*** Proof Global manipulation ***)
@@ -142,9 +148,6 @@ let cur_pstate () =
let give_me_the_proof () = (cur_pstate ()).proof
let get_current_proof_name () = (cur_pstate ()).pid
-let interp_tac = ref (fun _ -> assert false)
-let set_interp_tac f = interp_tac := f
-
let with_current_proof f =
match !pstates with
| [] -> raise NoCurrentProof
@@ -152,7 +155,13 @@ let with_current_proof f =
let et =
match p.endline_tactic with
| None -> Proofview.tclUNIT ()
- | Some tac -> !interp_tac tac in
+ | Some tac ->
+ let open Geninterp in
+ let ist = { lfun = Id.Map.empty; extra = TacStore.empty } in
+ let Genarg.GenArg (Genarg.Glbwit tag, tac) = tac in
+ let tac = Geninterp.interp tag ist tac in
+ Ftactic.run tac (fun _ -> Proofview.tclUNIT ())
+ in
let (newpr,ret) = f et p.proof in
let p = { p with proof = newpr } in
pstates := p :: rest;
@@ -186,7 +195,7 @@ let check_no_pending_proof () =
if not (there_are_pending_proofs ()) then
()
else begin
- Errors.error (Pp.string_of_ppcmds
+ CErrors.error (Pp.string_of_ppcmds
(str"Proof editing in progress" ++ msg_proofs () ++ fnl() ++
str"Use \"Abort All\" first or complete proof(s)."))
end
@@ -198,8 +207,8 @@ let discard (loc,id) =
let n = List.length !pstates in
discard_gen id;
if Int.equal (List.length !pstates) n then
- Errors.user_err_loc
- (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs ())
+ CErrors.user_err ~loc
+ ~hdr:"Pfedit.delete_proof" (str"No such proof" ++ msg_proofs ())
let discard_current () =
if List.is_empty !pstates then raise NoCurrentProof else pstates := List.tl !pstates
@@ -219,8 +228,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
@@ -272,7 +281,7 @@ let set_used_variables l =
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 get_id ctx) Id.Set.empty in
+ List.fold_right Id.Set.add (List.map NamedDecl.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
@@ -292,7 +301,7 @@ let set_used_variables l =
| [] -> raise NoCurrentProof
| p :: rest ->
if not (Option.is_empty p.section_vars) then
- Errors.error "Used section variables can be declared only once";
+ CErrors.error "Used section variables can be declared only once";
pstates := { p with section_vars = Some ctx} :: rest;
ctx, to_clear
@@ -404,7 +413,7 @@ let return_proof ?(allow_partial=false) () =
let evd =
let error s =
let prf = str " (in proof " ++ Id.print pid ++ str ")" in
- raise (Errors.UserError("last tactic before Qed",s ++ prf))
+ raise (CErrors.UserError(Some "last tactic before Qed",s ++ prf))
in
try Proof.return proof with
| Proof.UnfinishedProof ->
@@ -511,12 +520,12 @@ module Bullet = struct
exception FailedBullet of t * suggestion
let _ =
- Errors.register_handler
+ CErrors.register_handler
(function
| FailedBullet (b,sugg) ->
let prefix = str"Wrong bullet " ++ pr_bullet b ++ str" : " in
- Errors.errorlabstrm "Focus" (prefix ++ suggest_on_error sugg)
- | _ -> raise Errors.Unhandled)
+ CErrors.user_err ~hdr:"Focus" (prefix ++ suggest_on_error sugg)
+ | _ -> raise CErrors.Unhandled)
(* spiwack: we need only one focus kind as we keep a stack of (distinct!) bullets *)
@@ -613,7 +622,7 @@ module Bullet = struct
let _ = register_behavior strict
end
- (* Current bullet behavior, controled by the option *)
+ (* Current bullet behavior, controlled by the option *)
let current_behavior = ref Strict.strict
let _ =
@@ -629,7 +638,7 @@ module Bullet = struct
current_behavior :=
try Hashtbl.find behaviors n
with Not_found ->
- Errors.error ("Unknown bullet behavior: \"" ^ n ^ "\".")
+ CErrors.error ("Unknown bullet behavior: \"" ^ n ^ "\".")
end
}
@@ -660,20 +669,26 @@ let _ =
let default_goal_selector = ref (Vernacexpr.SelectNth 1)
let get_default_goal_selector () = !default_goal_selector
+let print_range_selector (i, j) =
+ if i = j then string_of_int i
+ else string_of_int i ^ "-" ^ string_of_int j
+
let print_goal_selector = function
| Vernacexpr.SelectAll -> "all"
| Vernacexpr.SelectNth i -> string_of_int i
+ | Vernacexpr.SelectList l -> "[" ^
+ String.concat ", " (List.map print_range_selector l) ^ "]"
| Vernacexpr.SelectId id -> Id.to_string id
let parse_goal_selector = function
| "all" -> Vernacexpr.SelectAll
| i ->
- let err_msg = "A selector must be \"all\" or a natural number." in
+ let err_msg = "The default selector must be \"all\" or a natural number." in
begin try
let i = int_of_string i in
- if i < 0 then Errors.error err_msg;
+ if i < 0 then CErrors.error err_msg;
Vernacexpr.SelectNth i
- with Failure _ -> Errors.error err_msg
+ with Failure _ -> CErrors.error err_msg
end
let _ =
@@ -702,7 +717,7 @@ type state = pstate list
let freeze ~marshallable =
match marshallable with
| `Yes ->
- Errors.anomaly (Pp.str"full marshalling of proof state not supported")
+ CErrors.anomaly (Pp.str"full marshalling of proof state not supported")
| `Shallow -> !pstates
| `No -> !pstates
let unfreeze s = pstates := s; update_proof_mode ()
diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli
index ebe7f6d6f3..97a21cf225 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
@@ -132,17 +134,14 @@ val simple_with_current_proof :
(unit Proofview.tactic -> Proof.proof -> Proof.proof) -> unit
(** Sets the tactic to be used when a tactic line is closed with [...] *)
-val set_endline_tactic : Tacexpr.raw_tactic_expr -> unit
-val set_interp_tac :
- (Tacexpr.raw_tactic_expr -> unit Proofview.tactic)
- -> unit
+val set_endline_tactic : Genarg.glob_generic_argument -> unit
(** Sets the section variables assumed by the proof, returns its closure
* (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
+ Names.Id.t list -> Context.Named.t * (Loc.t * Names.Id.t) list
+val get_used_variables : unit -> Context.Named.t option
val get_universe_binders : unit -> universe_binders option
@@ -153,8 +152,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..03bc5e4710 100644
--- a/proofs/proof_type.mli
+++ b/proofs/proof_type.mli
@@ -6,10 +6,11 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(** Legacy proof engine. Do not use in newly written code. *)
+
open Evd
open Names
open Term
-open Tacexpr
open Glob_term
open Nametab
open Misctypes
@@ -19,41 +20,12 @@ 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 *)
type rule = prim_rule
-(** The type [goal sigma] is the type of subgoal. It has the following form
-{v it = \{ evar_concl = [the conclusion of the subgoal]
- evar_hyps = [the hypotheses of the subgoal]
- evar_body = Evar_Empty;
- evar_info = \{ pgm : [The Realizer pgm if any]
- lc : [Set of evar num occurring in subgoal] \}\}
- sigma = \{ stamp = [an int chardacterizing the ed field, for quick compare]
- ed : [A set of existential variables depending in the subgoal]
- number of first evar,
- it = \{ evar_concl = [the type of first evar]
- evar_hyps = [the context of the evar]
- evar_body = [the body of the Evar if any]
- evar_info = \{ pgm : [Useless ??]
- lc : [Set of evars occurring
- in the type of evar] \} \};
- ...
- number of last evar,
- it = \{ evar_concl = [the type of evar]
- evar_hyps = [the context of the evar]
- evar_body = [the body of the Evar if any]
- evar_info = \{ pgm : [Useless ??]
- lc : [Set of evars occurring
- in the type of evar] \} \} \} v}
-*)
-
type goal = Goal.goal
type tactic = goal sigma -> goal list sigma
diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml
index 681a7fa1ad..a125fb10db 100644
--- a/proofs/proof_using.ml
+++ b/proofs/proof_using.ml
@@ -12,6 +12,8 @@ open Util
open Vernacexpr
open Context.Named.Declaration
+module NamedDecl = Context.Named.Declaration
+
let to_string e =
let rec aux = function
| SsEmpty -> "()"
@@ -35,12 +37,14 @@ let in_nameset =
let rec close_fwd e s =
let s' =
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 vb = match decl with
+ | LocalAssum _ -> Id.Set.empty
+ | LocalDef (_,b,_) -> global_vars_set e b
+ in
+ let vty = global_vars_set e (NamedDecl.get_type decl) 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)
+ then Id.Set.add (NamedDecl.get_id decl) (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'
@@ -63,13 +67,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 get_id (named_context env)) Id.Set.empty
+ List.fold_right Id.Set.add (List.map NamedDecl.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 get_id (named_context env)) Id.Set.empty
+ List.fold_right Id.Set.add (List.map NamedDecl.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
@@ -128,7 +132,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/proof_using.mli b/proofs/proof_using.mli
index 1bf38b6908..b2c65412f8 100644
--- a/proofs/proof_using.mli
+++ b/proofs/proof_using.mli
@@ -6,6 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(** Utility code for section variables handling in Proof using... *)
+
val process_expr :
Environ.env -> Vernacexpr.section_subset_expr -> Constr.types list ->
Names.Id.t list
diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib
index 9130a186ba..804a543605 100644
--- a/proofs/proofs.mllib
+++ b/proofs/proofs.mllib
@@ -2,7 +2,6 @@ Miscprint
Goal
Evar_refiner
Proof_using
-Proof_errors
Logic
Refine
Proof
diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml
index 2d886b8e1f..34443b93da 100644
--- a/proofs/redexpr.ml
+++ b/proofs/redexpr.ml
@@ -7,7 +7,7 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Term
@@ -17,7 +17,7 @@ open Genredexpr
open Pattern
open Reductionops
open Tacred
-open Closure
+open CClosure
open RedFlags
open Libobject
open Misctypes
@@ -29,17 +29,22 @@ let cbv_vm env sigma c =
error "vm_compute does not support existential variables.";
Vnorm.cbv_vm env c ctyp
+let warn_native_compute_disabled =
+ CWarnings.create ~name:"native-compute-disabled" ~category:"native-compiler"
+ (fun () ->
+ 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
- let () = msg_warning (str "native_compute disabled at configure time; falling back to vm_compute.") in
- cbv_vm env sigma c
+ (warn_native_compute_disabled ();
+ cbv_vm env sigma c)
else
let ctyp = Retyping.get_type_of env sigma c in
Nativenorm.native_norm env sigma c ctyp
let whd_cbn flags env sigma t =
let (state,_) =
- (whd_state_gen true flags env sigma (t,Reductionops.Stack.empty))
+ (whd_state_gen true true flags env sigma (t,Reductionops.Stack.empty))
in Reductionops.Stack.zip ~refold:true state
let strong_cbn flags =
@@ -68,7 +73,7 @@ let set_strategy_one ref l =
let cb = Global.lookup_constant sp in
(match cb.const_body with
| OpaqueDef _ ->
- errorlabstrm "set_transparent_const"
+ user_err ~hdr:"set_transparent_const"
(str "Cannot make" ++ spc () ++
Nametab.pr_global_env Id.Set.empty (ConstRef sp) ++
spc () ++ str "transparent because it was declared opaque.");
@@ -141,7 +146,9 @@ let make_flag_constant = function
let make_flag env f =
let red = no_red in
let red = if f.rBeta then red_add red fBETA else red in
- let red = if f.rIota then red_add red fIOTA else red in
+ let red = if f.rMatch then red_add red fMATCH else red in
+ let red = if f.rFix then red_add red fFIX else red in
+ let red = if f.rCofix then red_add red fCOFIX else red in
let red = if f.rZeta then red_add red fZETA else red in
let red =
if f.rDelta then (* All but rConst *)
@@ -168,19 +175,19 @@ let red_expr_tab = Summary.ref String.Map.empty ~name:"Declare Reduction"
let declare_reduction s f =
if String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab
- then errorlabstrm "Redexpr.declare_reduction"
+ then user_err ~hdr:"Redexpr.declare_reduction"
(str "There is already a reduction expression of name " ++ str s)
else reduction_tab := String.Map.add s f !reduction_tab
let check_custom = function
| ExtraRedExpr s ->
if not (String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab)
- then errorlabstrm "Redexpr.check_custom" (str "Reference to undefined reduction expression " ++ str s)
+ then user_err ~hdr:"Redexpr.check_custom" (str "Reference to undefined reduction expression " ++ str s)
|_ -> ()
let decl_red_expr s e =
if String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab
- then errorlabstrm "Redexpr.decl_red_expr"
+ then user_err ~hdr:"Redexpr.decl_red_expr"
(str "There is already a reduction expression of name " ++ str s)
else begin
check_custom e;
@@ -209,6 +216,11 @@ let contextualize f g = function
e_red (contextually b (l,c) (fun _ -> h))
| None -> e_red g
+let warn_simpl_unfolding_modifiers =
+ CWarnings.create ~name:"simpl-unfolding-modifiers" ~category:"tactics"
+ (fun () ->
+ Pp.strbrk "The legacy simpl ignores constant unfolding modifiers.")
+
let reduction_of_red_expr env =
let make_flag = make_flag env in
let rec reduction_of_red_expr = function
@@ -221,7 +233,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
+ warn_simpl_unfolding_modifiers () 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 ->
@@ -235,7 +247,7 @@ let reduction_of_red_expr env =
with Not_found ->
(try reduction_of_red_expr (String.Map.find s !red_expr_tab)
with Not_found ->
- errorlabstrm "Redexpr.reduction_of_red_expr"
+ user_err ~hdr:"Redexpr.reduction_of_red_expr"
(str "unknown user-defined reduction \"" ++ str s ++ str "\"")))
| CbvVm o -> (contextualize cbv_vm cbv_vm o, VMcast)
| CbvNative o -> (contextualize cbv_native cbv_native o, NATIVEcast)
diff --git a/proofs/redexpr.mli b/proofs/redexpr.mli
index b91911087d..d4c2c4a6c9 100644
--- a/proofs/redexpr.mli
+++ b/proofs/redexpr.mli
@@ -6,6 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(** Interpretation layer of redexprs such as hnf, cbv, etc. *)
+
open Names
open Term
open Pattern
diff --git a/proofs/refine.ml b/proofs/refine.ml
index db0b26f7e5..c238f731d5 100644
--- a/proofs/refine.ml
+++ b/proofs/refine.ml
@@ -6,13 +6,13 @@
(* * 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
+module NamedDecl = Context.Named.Declaration
+
let extract_prefix env info =
let ctx1 = List.rev (Environ.named_context env) in
let ctx2 = List.rev (Evd.evar_context info) in
@@ -28,7 +28,7 @@ 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 t = NamedDecl.get_type decl in
let evdref = ref sigma in
let _ = Typing.e_sort_of env evdref t in
let () = match decl with
@@ -53,7 +53,25 @@ let typecheck_proof c concl env sigma =
let (pr_constrv,pr_constr) =
Hook.make ~default:(fun _env _sigma _c -> Pp.str"<constr>") ()
-let refine ?(unsafe = true) f = Proofview.Goal.enter { enter = begin fun gl ->
+(* Get the side-effect's constant declarations to update the monad's
+ * environmnent *)
+let add_if_undefined kn cb env =
+ try ignore(Environ.lookup_constant kn env); env
+ with Not_found -> Environ.add_constant kn cb env
+
+(* Add the side effects to the monad's environment, if not already done. *)
+let add_side_effect env = function
+ | { Entries.eff = Entries.SEsubproof (kn, cb, eff_env) } ->
+ add_if_undefined kn cb env
+ | { Entries.eff = Entries.SEscheme (l,_) } ->
+ List.fold_left (fun env (_,kn,cb,eff_env) ->
+ add_if_undefined kn cb env) env l
+
+let add_side_effects env effects =
+ List.fold_left (fun env eff -> add_side_effect env eff) env effects
+
+let make_refine_enter ?(unsafe = true) f =
+ { enter = fun gl ->
let gl = Proofview.Goal.assume gl in
let sigma = Proofview.Goal.sigma gl in
let sigma = Sigma.to_evar_map sigma in
@@ -64,9 +82,13 @@ let refine ?(unsafe = true) f = Proofview.Goal.enter { enter = begin fun gl ->
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 ((v,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
+ (** Redo the effects in sigma in the monad's env *)
+ let privates_csts = Evd.eval_side_effects sigma in
+ let sideff = Safe_typing.side_effects_of_private_constants privates_csts in
+ 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
@@ -93,11 +115,20 @@ let refine ?(unsafe = true) f = Proofview.Goal.enter { enter = begin fun gl ->
(** 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 }
+ let trace () = Pp.(hov 2 (str"simple refine"++spc()++ Hook.get pr_constrv env sigma c)) in
+ Proofview.Trace.name_tactic trace (Proofview.tclUNIT v) >>= fun v ->
+ Proofview.Unsafe.tclSETENV (Environ.reset_context env) <*>
+ Proofview.Unsafe.tclEVARS sigma <*>
+ Proofview.Unsafe.tclSETGOALS comb <*>
+ Proofview.tclUNIT v
+ }
+
+let refine_one ?(unsafe = true) f =
+ Proofview.Goal.enter_one (make_refine_enter ~unsafe f)
+
+let refine ?(unsafe = true) f =
+ let f = { run = fun sigma -> let Sigma (c,sigma,p) = f.run sigma in Sigma (((),c),sigma,p) } in
+ Proofview.Goal.enter (make_refine_enter ~unsafe f)
(** Useful definitions *)
@@ -120,3 +151,14 @@ let refine_casted ?unsafe f = Proofview.Goal.enter { enter = begin fun gl ->
} in
refine ?unsafe f
end }
+
+(** {7 solve_constraints}
+
+ Ensure no remaining unification problems are left. Run at every "." by default. *)
+
+let solve_constraints =
+ let open Proofview in
+ tclENV >>= fun env -> tclEVARMAP >>= fun sigma ->
+ try let sigma = Evarconv.solve_unif_constraints_with_heuristics env sigma in
+ Unsafe.tclEVARSADVANCE sigma
+ with e -> tclZERO e
diff --git a/proofs/refine.mli b/proofs/refine.mli
index 17c7e28ca9..a44632eff5 100644
--- a/proofs/refine.mli
+++ b/proofs/refine.mli
@@ -6,6 +6,11 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(** The primitive refine tactic used to fill the holes in partial proofs. This
+ is the recommanded way to write tactics when the proof term is easy to
+ write down. Note that this is not the user-level refine tactic defined
+ in Ltac which is actually based on the one below. *)
+
open Proofview
(** {6 The refine tactic} *)
@@ -25,6 +30,9 @@ val refine : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic
tactic failures. If [unsafe] is [false] (default is [true]) [t] is
type-checked beforehand. *)
+val refine_one : ?unsafe:bool -> ('a * Constr.t) Sigma.run -> 'a tactic
+(** A generalization of [refine] which assumes exactly one goal under focus *)
+
(** {7 Helper functions} *)
val with_type : Environ.env -> Evd.evar_map ->
@@ -35,3 +43,8 @@ val with_type : Environ.env -> Evd.evar_map ->
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. *)
+
+(** {7 Unification constraint handling} *)
+
+val solve_constraints : unit tactic
+(** Solve any remaining unification problems, applying heuristics. *)
diff --git a/proofs/refiner.ml b/proofs/refiner.ml
index 186525e159..9a0b56b84b 100644
--- a/proofs/refiner.ml
+++ b/proofs/refiner.ml
@@ -7,13 +7,14 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Evd
open Environ
open Proof_type
open Logic
-open Context.Named.Declaration
+
+module NamedDecl = Context.Named.Declaration
let sig_it x = x.it
let project x = x.sigma
@@ -57,10 +58,10 @@ 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)
+let tclFAIL_s s gls = user_err ~hdr:"Refiner.tclFAIL_s" (str s)
(* A special exception for levels for the Fail tactic *)
exception FailError of int * std_ppcmds Lazy.t
@@ -82,7 +83,7 @@ let thens3parts_tac tacfi tac tacli (sigr,gs) =
let nf = Array.length tacfi in
let nl = Array.length tacli in
let ng = List.length gs in
- if ng<nf+nl then errorlabstrm "Refiner.thensn_tac" (str "Not enough subgoals.");
+ if ng<nf+nl then user_err ~hdr:"Refiner.thensn_tac" (str "Not enough subgoals.");
let gll =
(List.map_i (fun i ->
apply_sig_tac sigr (if i<nf then tacfi.(i) else if i>=ng-nl then tacli.(nl-ng+i) else tac))
@@ -164,14 +165,14 @@ the goal unchanged *)
let tclWEAK_PROGRESS tac ptree =
let rslt = tac ptree in
if Goal.V82.weak_progress rslt ptree then rslt
- else errorlabstrm "Refiner.WEAK_PROGRESS" (str"Failed to progress.")
+ else user_err ~hdr:"Refiner.WEAK_PROGRESS" (str"Failed to progress.")
(* PROGRESS tac ptree applies tac to the goal ptree and fails if tac leaves
the goal unchanged *)
let tclPROGRESS tac ptree =
let rslt = tac ptree in
if Goal.V82.progress rslt ptree then rslt
- else errorlabstrm "Refiner.PROGRESS" (str"Failed to progress.")
+ else user_err ~hdr:"Refiner.PROGRESS" (str"Failed to progress.")
(* Same as tclWEAK_PROGRESS but fails also if tactics generates several goals,
one of them being identical to the original goal *)
@@ -182,7 +183,7 @@ let tclNOTSAMEGOAL (tac : tactic) goal =
let rslt = tac goal in
let {it=gls;sigma=sigma} = rslt in
if List.exists (same_goal goal sigma) gls
- then errorlabstrm "Refiner.tclNOTSAMEGOAL"
+ then user_err ~hdr:"Refiner.tclNOTSAMEGOAL"
(str"Tactic generated a subgoal identical to the original goal.")
else rslt
@@ -202,7 +203,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 d1 d2 = Names.Id.equal (get_id d1) (get_id d2) in
+ let cmp d1 d2 = Names.Id.equal (NamedDecl.get_id d1) (NamedDecl.get_id d2) in
let newhyps =
List.map
(fun hypl -> List.subtract cmp hypl oldhyps)
@@ -215,12 +216,13 @@ 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 d -> (Names.Id.to_string (get_id d)) ^ " " ^ acc)
+ (fun acc d -> (Names.Id.to_string (NamedDecl.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());
+ ++ (str (emacs_str "</infoH>")));
tclIDTAC goal;;
@@ -239,8 +241,8 @@ let tclORELSE0 t1 t2 g =
try
t1 g
with (* Breakpoint *)
- | e when Errors.noncritical e ->
- let e = Errors.push e in catch_failerror e; t2 g
+ | e when CErrors.noncritical e ->
+ let e = CErrors.push e in catch_failerror e; t2 g
(* ORELSE t1 t2 tries to apply t1 and if it fails or does not progress,
then applies t2 *)
@@ -252,8 +254,8 @@ let tclORELSE t1 t2 = tclORELSE0 (tclPROGRESS t1) t2
let tclORELSE_THEN t1 t2then t2else gls =
match
try Some(tclPROGRESS t1 gls)
- with e when Errors.noncritical e ->
- let e = Errors.push e in catch_failerror e; None
+ with e when CErrors.noncritical e ->
+ let e = CErrors.push e in catch_failerror e; None
with
| None -> t2else gls
| Some sgl ->
@@ -283,12 +285,12 @@ let ite_gen tcal tac_if continue tac_else gl=
try
tac_else gl
with
- e' when Errors.noncritical e' -> iraise e in
+ e' when CErrors.noncritical e' -> iraise e in
try
tcal tac_if0 continue gl
with (* Breakpoint *)
- | e when Errors.noncritical e ->
- let e = Errors.push e in catch_failerror e; tac_else0 e gl
+ | e when CErrors.noncritical e ->
+ let e = CErrors.push e in catch_failerror e; tac_else0 e gl
(* Try the first tactic and, if it succeeds, continue with
the second one, and if it fails, use the third one *)
@@ -315,7 +317,7 @@ let tclSOLVE tacl = tclFIRST (List.map tclCOMPLETE tacl)
let tclDO n t =
let rec dorec k =
- if k < 0 then errorlabstrm "Refiner.tclDO"
+ if k < 0 then user_err ~hdr:"Refiner.tclDO"
(str"Wrong argument : Do needs a positive integer.");
if Int.equal k 0 then tclIDTAC
else if Int.equal k 1 then t else (tclTHEN t (dorec (k-1)))
diff --git a/proofs/refiner.mli b/proofs/refiner.mli
index dd9153a023..6dcafb77a4 100644
--- a/proofs/refiner.mli
+++ b/proofs/refiner.mli
@@ -6,6 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(** Legacy proof engine. Do not use in newly written code. *)
+
open Evd
open Proof_type
diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml
index 33cef7486b..030a3cbfb9 100644
--- a/proofs/tacmach.ml
+++ b/proofs/tacmach.ml
@@ -21,6 +21,8 @@ open Refiner
open Sigma.Notations
open Context.Named.Declaration
+module NamedDecl = Context.Named.Declaration
+
let re_sig it gc = { it = it; sigma = gc; }
(**************************************************************)
@@ -46,7 +48,7 @@ let pf_hyps_types gls =
| LocalDef (id,_,x) -> id, x)
sign
-let pf_nth_hyp_id gls n = List.nth (pf_hyps gls) (n-1) |> get_id
+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)
@@ -57,7 +59,7 @@ let pf_get_hyp gls id =
raise (RefinerError (NoSuchHyp id))
let pf_get_hyp_typ gls id =
- pf_get_hyp gls id |> get_type
+ id |> pf_get_hyp gls |> NamedDecl.get_type
let pf_ids_of_hyps gls = ids_of_named_context (pf_hyps gls)
@@ -84,7 +86,7 @@ let pf_eapply f gls x =
let pf_reduce = pf_apply
let pf_e_reduce = pf_apply
-let pf_whd_betadeltaiota = pf_reduce whd_betadeltaiota
+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)
@@ -101,7 +103,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 = pf_whd_betadeltaiota gls % pf_get_type_of gls
+let pf_hnf_type_of gls = pf_get_type_of gls %> pf_whd_all gls
let pf_is_matching = pf_apply Constr_matching.is_matching_conv
let pf_matches = pf_apply Constr_matching.matches_conv
@@ -121,26 +123,11 @@ 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 *)
@@ -186,6 +173,9 @@ module New = struct
let pf_unsafe_type_of gl t =
pf_apply unsafe_type_of gl t
+ let pf_get_type_of gl t =
+ pf_apply (Retyping.get_type_of ~lax:true) gl t
+
let pf_type_of gl t =
pf_apply type_of gl t
@@ -202,15 +192,15 @@ module New = struct
next_ident_away id ids
let pf_get_hyp id gl =
- let hyps = Proofview.Goal.hyps gl in
+ let hyps = Proofview.Goal.env gl in
let sign =
- try Context.Named.lookup id hyps
+ try Environ.lookup_named id hyps
with Not_found -> raise (RefinerError (NoSuchHyp id))
in
sign
let pf_get_hyp_typ id gl =
- pf_get_hyp id gl |> get_type
+ pf_get_hyp id gl |> NamedDecl.get_type
let pf_hyps_types gl =
let env = Proofview.Goal.env gl in
@@ -230,7 +220,7 @@ module New = struct
let sigma = project gl in
nf_evar sigma concl
- let pf_whd_betadeltaiota gl t = pf_apply whd_betadeltaiota gl t
+ let pf_whd_all gl t = pf_apply whd_all gl t
let pf_get_type_of gl t = pf_apply Retyping.get_type_of gl t
@@ -239,11 +229,11 @@ module New = struct
let pf_hnf_constr gl t = pf_apply hnf_constr gl t
let pf_hnf_type_of gl t =
- pf_whd_betadeltaiota gl (pf_get_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_betadeltaiota gl t = pf_apply whd_betadeltaiota gl t
+ let pf_whd_all gl t = pf_apply whd_all gl t
let pf_compute gl t = pf_apply compute gl t
let pf_nf_evar gl t = nf_evar (project gl) t
diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli
index f786b5f218..59f296f64e 100644
--- a/proofs/tacmach.mli
+++ b/proofs/tacmach.mli
@@ -63,7 +63,7 @@ val pf_e_reduce :
(env -> evar_map -> constr -> evar_map * constr) ->
goal sigma -> constr -> evar_map * constr
-val pf_whd_betadeltaiota : goal sigma -> constr -> constr
+val pf_whd_all : goal sigma -> constr -> constr
val pf_hnf_constr : goal sigma -> constr -> constr
val pf_nf : goal sigma -> constr -> constr
val pf_nf_betaiota : goal sigma -> constr -> constr
@@ -86,18 +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). } *)
val pr_gls : goal sigma -> Pp.std_ppcmds
@@ -114,7 +108,16 @@ module New : sig
val pf_env : ('a, 'r) Proofview.Goal.t -> Environ.env
val pf_concl : ([ `NF ], 'r) 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, 'r) Proofview.Goal.t -> Term.constr -> Term.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, 'r) Proofview.Goal.t -> Term.constr -> Term.types
+
+ (** This function entirely type-checks the term and computes its type
+ and the implied universe constraints. *)
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
@@ -132,7 +135,7 @@ module New : sig
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, 'r) Proofview.Goal.t -> constr -> constr
+ val pf_whd_all : ('a, 'r) Proofview.Goal.t -> constr -> constr
val pf_compute : ('a, 'r) Proofview.Goal.t -> constr -> constr
val pf_matches : ('a, 'r) Proofview.Goal.t -> constr_pattern -> constr -> patvar_map
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-28 11:04:30 +0000