aboutsummaryrefslogtreecommitdiffhomepage
path: root/engine/proofview.ml
diff options
context:
space:
mode:
Diffstat (limited to 'engine/proofview.ml')
-rw-r--r--engine/proofview.ml152
1 files changed, 69 insertions, 83 deletions
diff --git a/engine/proofview.ml b/engine/proofview.ml
index cc63ee21a..c542fd976 100644
--- a/engine/proofview.ml
+++ b/engine/proofview.ml
@@ -16,13 +16,14 @@
open Pp
open Util
open Proofview_monad
-open Sigma.Notations
open Context.Named.Declaration
(** Main state of tactics *)
type proofview = Proofview_monad.proofview
-type entry = (Term.constr * Term.types) list
+(* The first items in pairs below are proofs (under construction).
+ The second items in the pairs below are statements that are being proved. *)
+type entry = (EConstr.constr * EConstr.types) list
(** Returns a stylised view of a proofview for use by, for instance,
ide-s. *)
@@ -35,15 +36,16 @@ let proofview p =
p.comb , p.solution
let compact el ({ solution } as pv) =
- let nf = Evarutil.nf_evar solution in
+ let nf c = Evarutil.nf_evar solution c in
+ let nf0 c = EConstr.Unsafe.to_constr (Evarutil.nf_evar solution (EConstr.of_constr c)) in
let size = Evd.fold (fun _ _ i -> i+1) solution 0 in
let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in
let pruned_solution = Evd.drop_all_defined solution in
let apply_subst_einfo _ ei =
Evd.({ ei with
- evar_concl = nf ei.evar_concl;
- evar_hyps = Environ.map_named_val nf ei.evar_hyps;
- evar_candidates = Option.map (List.map nf) ei.evar_candidates }) in
+ evar_concl = nf0 ei.evar_concl;
+ evar_hyps = Environ.map_named_val nf0 ei.evar_hyps;
+ evar_candidates = Option.map (List.map nf0) ei.evar_candidates }) in
let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in
let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in
Feedback.msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size));
@@ -54,7 +56,7 @@ let compact el ({ solution } as pv) =
type telescope =
| TNil of Evd.evar_map
- | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope)
+ | TCons of Environ.env * Evd.evar_map * EConstr.types * (Evd.evar_map -> EConstr.constr -> telescope)
let typeclass_resolvable = Evd.Store.field ()
@@ -63,16 +65,14 @@ let dependent_init =
for type classes. *)
let store = Evd.Store.set Evd.Store.empty typeclass_resolvable () in
(* Goals don't have a source location. *)
- let src = (Loc.ghost,Evar_kinds.GoalEvar) in
+ let src = Loc.tag @@ Evar_kinds.GoalEvar in
(* Main routine *)
let rec aux = function
| TNil sigma -> [], { solution = sigma; comb = []; shelf = [] }
| TCons (env, sigma, typ, t) ->
- let sigma = Sigma.Unsafe.of_evar_map sigma in
- let Sigma (econstr, sigma, _) = Evarutil.new_evar env sigma ~src ~store typ in
- let sigma = Sigma.to_evar_map sigma in
+ let (sigma, econstr) = Evarutil.new_evar env sigma ~src ~store typ in
+ let (gl, _) = EConstr.destEvar sigma econstr in
let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in
- let (gl, _) = Term.destEvar econstr in
let entry = (econstr, typ) :: ret in
entry, { solution = sol; comb = gl :: comb; shelf = [] }
in
@@ -286,7 +286,7 @@ let tclONCE = Proof.once
exception MoreThanOneSuccess
let _ = CErrors.register_handler begin function
- | MoreThanOneSuccess -> CErrors.error "This tactic has more than one success."
+ | MoreThanOneSuccess -> CErrors.user_err Pp.(str "This tactic has more than one success.")
| _ -> raise CErrors.Unhandled
end
@@ -341,7 +341,7 @@ let set_nosuchgoals_hook f = nosuchgoals_hook := f
let _ = CErrors.register_handler begin function
| NoSuchGoals n ->
let suffix = !nosuchgoals_hook n in
- CErrors.errorlabstrm ""
+ CErrors.user_err
(str "No such " ++ str (String.plural n "goal") ++ str "." ++
pr_non_empty_arg (fun x -> x) suffix)
| _ -> raise CErrors.Unhandled
@@ -421,13 +421,13 @@ let tclFOCUSID id t =
exception SizeMismatch of int*int
let _ = CErrors.register_handler begin function
- | SizeMismatch (i,_) ->
+ | SizeMismatch (i,j) ->
let open Pp in
let errmsg =
str"Incorrect number of goals" ++ spc() ++
- str"(expected "++int i++str(String.plural i " tactic") ++ str")."
+ str"(expected "++int i++str(String.plural i " tactic") ++ str", was given "++ int j++str")."
in
- CErrors.errorlabstrm "" errmsg
+ CErrors.user_err errmsg
| _ -> raise CErrors.Unhandled
end
@@ -451,6 +451,25 @@ let iter_goal i =
Solution.get >>= fun evd ->
Comb.set CList.(undefined evd (flatten (rev subgoals)))
+(** List iter but allocates a list of results *)
+let map_goal i =
+ let rev = List.rev in (* hem... Proof masks List... *)
+ let open Proof in
+ Comb.get >>= fun initial ->
+ Proof.List.fold_left begin fun (acc, subgoals as cur) goal ->
+ Solution.get >>= fun step ->
+ match Evarutil.advance step goal with
+ | None -> return cur
+ | Some goal ->
+ Comb.set [goal] >>
+ i goal >>= fun res ->
+ Proof.map (fun comb -> comb :: subgoals) Comb.get >>= fun x ->
+ return (res :: acc, x)
+ end ([],[]) initial >>= fun (results_rev, subgoals) ->
+ Solution.get >>= fun evd ->
+ Comb.set CList.(undefined evd (flatten (rev subgoals))) >>
+ return (rev results_rev)
+
(** A variant of [Monad.List.fold_left2] where the first list is the
list of focused goals. The argument tactic is executed in a focus
comprising only of the current goal, a goal which has been solved
@@ -583,7 +602,15 @@ let tclINDEPENDENT tac =
let tac = InfoL.tag (Info.DBranch) tac in
InfoL.tag (Info.Dispatch) (iter_goal (fun _ -> tac))
-
+let tclINDEPENDENTL tac =
+ let open Proof in
+ Pv.get >>= fun initial ->
+ match initial.comb with
+ | [] -> tclUNIT []
+ | [_] -> tac >>= fun x -> return [x]
+ | _ ->
+ let tac = InfoL.tag (Info.DBranch) tac in
+ InfoL.tag (Info.Dispatch) (map_goal (fun _ -> tac))
(** {7 Goal manipulation} *)
@@ -666,6 +693,12 @@ let mark_in_evm ~goal evd content =
let info =
if goal then
{ info with Evd.evar_source = match info.Evd.evar_source with
+ (* Two kinds for goal evars:
+ - GoalEvar (morally not dependent)
+ - VarInstance (morally dependent of some name).
+ This is a heuristic for naming these evars. *)
+ | loc, (Evar_kinds.QuestionMark (_,Names.Name id) |
+ Evar_kinds.ImplicitArg (_,(_,Some id),_)) -> loc, Evar_kinds.VarInstance id
| _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x
| loc,_ -> loc,Evar_kinds.GoalEvar }
else info
@@ -837,11 +870,11 @@ let tclPROGRESS t =
if not test then
tclUNIT res
else
- tclZERO (CErrors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress."))
+ tclZERO (CErrors.UserError (Some "Proofview.tclPROGRESS" , Pp.str"Failed to progress."))
exception Timeout
let _ = CErrors.register_handler begin function
- | Timeout -> CErrors.errorlabstrm "Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!")
+ | Timeout -> CErrors.user_err ~hdr:"Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!")
| _ -> Pervasives.raise CErrors.Unhandled
end
@@ -976,31 +1009,25 @@ let catchable_exception = function
module Goal = struct
- type ('a, 'r) t = {
+ type 'a t = {
env : Environ.env;
sigma : Evd.evar_map;
- concl : Term.constr ;
+ concl : EConstr.constr ;
self : Evar.t ; (* for compatibility with old-style definitions *)
}
- type ('a, 'b) enter =
- { enter : 'r. ('a, 'r) t -> 'b }
-
- let assume (gl : ('a, 'r) t) = (gl :> ([ `NF ], 'r) t)
-
- let env { env=env } = env
- let sigma { sigma=sigma } = Sigma.Unsafe.of_evar_map sigma
- let hyps { env=env } = Environ.named_context env
- let concl { concl=concl } = concl
- let extra { sigma=sigma; self=self } = goal_extra sigma self
-
- let raw_concl { concl=concl } = concl
+ let assume (gl : 'a t) = (gl :> [ `NF ] t)
+ let env {env} = env
+ let sigma {sigma} = sigma
+ let hyps {env} = EConstr.named_context env
+ let concl {concl} = concl
+ let extra {sigma; self} = goal_extra sigma self
let gmake_with info env sigma goal =
{ env = Environ.reset_with_named_context (Evd.evar_filtered_hyps info) env ;
sigma = sigma ;
- concl = Evd.evar_concl info ;
+ concl = EConstr.of_constr (Evd.evar_concl info);
self = goal }
let nf_gmake env sigma goal =
@@ -1011,11 +1038,11 @@ module Goal = struct
let nf_enter f =
InfoL.tag (Info.Dispatch) begin
iter_goal begin fun goal ->
- Env.get >>= fun env ->
+ tclENV >>= fun env ->
tclEVARMAP >>= fun sigma ->
try
let (gl, sigma) = nf_gmake env sigma goal in
- tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f.enter gl))
+ tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f gl))
with e when catchable_exception e ->
let (e, info) = CErrors.push e in
tclZERO ~info e
@@ -1033,7 +1060,7 @@ module Goal = struct
gmake_with info env sigma goal
let enter f =
- let f gl = InfoL.tag (Info.DBranch) (f.enter gl) in
+ let f gl = InfoL.tag (Info.DBranch) (f gl) in
InfoL.tag (Info.Dispatch) begin
iter_goal begin fun goal ->
Env.get >>= fun env ->
@@ -1048,7 +1075,7 @@ module Goal = struct
exception NotExactlyOneSubgoal
let _ = CErrors.register_handler begin function
| NotExactlyOneSubgoal ->
- CErrors.errorlabstrm "" (Pp.str"Not exactly one subgoal.")
+ CErrors.user_err (Pp.str"Not exactly one subgoal.")
| _ -> raise CErrors.Unhandled
end
@@ -1058,48 +1085,13 @@ module Goal = struct
| [goal] -> begin
Env.get >>= fun env ->
tclEVARMAP >>= fun sigma ->
- try f.enter (gmake env sigma goal)
+ try f (gmake env sigma goal)
with e when catchable_exception e ->
let (e, info) = CErrors.push e in
tclZERO ~info e
end
| _ -> tclZERO NotExactlyOneSubgoal
- type ('a, 'b) s_enter =
- { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma }
-
- let s_enter f =
- InfoL.tag (Info.Dispatch) begin
- iter_goal begin fun goal ->
- Env.get >>= fun env ->
- tclEVARMAP >>= fun sigma ->
- try
- let gl = gmake env sigma goal in
- let Sigma (tac, sigma, _) = f.s_enter gl in
- let sigma = Sigma.to_evar_map sigma in
- tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac)
- with e when catchable_exception e ->
- let (e, info) = CErrors.push e in
- tclZERO ~info e
- end
- end
-
- let nf_s_enter f =
- InfoL.tag (Info.Dispatch) begin
- iter_goal begin fun goal ->
- Env.get >>= fun env ->
- tclEVARMAP >>= fun sigma ->
- try
- let (gl, sigma) = nf_gmake env sigma goal in
- let Sigma (tac, sigma, _) = f.s_enter gl in
- let sigma = Sigma.to_evar_map sigma in
- tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac)
- with e when catchable_exception e ->
- let (e, info) = CErrors.push e in
- tclZERO ~info e
- end
- end
-
let goals =
Pv.get >>= fun step ->
let sigma = step.solution in
@@ -1123,8 +1115,6 @@ module Goal = struct
(* compatibility *)
let goal { self=self } = self
- let lift (gl : ('a, 'r) t) _ = (gl :> ('a, 's) t)
-
end
@@ -1213,12 +1203,12 @@ module V82 = struct
{ Evd.it = comb ; sigma = solution }
let top_goals initial { solution=solution; } =
- let goals = CList.map (fun (t,_) -> fst (Term.destEvar t)) initial in
+ let goals = CList.map (fun (t,_) -> fst (Term.destEvar (EConstr.Unsafe.to_constr t))) initial in
{ Evd.it = goals ; sigma=solution; }
let top_evars initial =
let evars_of_initial (c,_) =
- Evar.Set.elements (Evd.evars_of_term c)
+ Evar.Set.elements (Evd.evars_of_term (EConstr.Unsafe.to_constr c))
in
CList.flatten (CList.map evars_of_initial initial)
@@ -1248,8 +1238,4 @@ module Notations = struct
let (>>=) = tclBIND
let (<*>) = tclTHEN
let (<+>) t1 t2 = tclOR t1 (fun _ -> t2)
- type ('a, 'b) enter = ('a, 'b) Goal.enter =
- { enter : 'r. ('a, 'r) Goal.t -> 'b }
- type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter =
- { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma }
end
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-30 09:40:13 +0000