diff options
| author |  Maxime Dénès <mail@maximedenes.fr> | 2017-05-09 22:14:35 +0200 |
|---|---|---|
| committer | Maxime Dénès <mail@maximedenes.fr> | 2017-06-06 12:58:57 +0200 |
| commit | 954fbd3b102060ed1e2122f571a430f05a174e42 (patch) | |
| tree | a6f3db424624eae05ded3be6a84357d1ad291eda | |
| parent | 2f23c27e08f66402b8fba4745681becd402f4c5c (diff) | |
Remove the Sigma (monotonous state) API.
Reminder of (some of) the reasons for removal:
- Despite the claim in sigma.mli, it does *not* prevent evar
leaks, something like:
fun env evd ->
let (evd',ev) = new_evar env evd in
(evd,ev)
will typecheck even with Sigma-like type annotations (with a proof of
reflexivity)
- The API stayed embryonic. Even typing functions were not ported to
Sigma.
- Some unsafe combinators (Unsafe.tclEVARS) were replaced with slightly
less unsafe ones (e.g. s_enter), but those ones were not marked unsafe
at all (despite still being so).
- There was no good story for higher order functions manipulating evar
maps. Without higher order, one can most of the time get away with
reusing the same name for the updated evar map.
- Most of the code doing complex things with evar maps was using unsafe
casts to sigma. This code should be fixed, but this is an orthogonal
issue.
Of course, this was showing a nice and elegant use of GADTs, but the
cost/benefit ratio in practice did not seem good.
91 files changed, 1315 insertions, 1916 deletions
diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 33d7acc31..078f2fc33 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -780,9 +780,8 @@ let lookup_named n e = cast_named_decl (sym unsafe_eq) (lookup_named n e) let lookup_named_val n e = cast_named_decl (sym unsafe_eq) (lookup_named_val n e) let fresh_global ?loc ?rigid ?names env sigma reference = - let Sigma.Sigma (t,sigma,p) = - Sigma.fresh_global ?loc ?rigid ?names env sigma reference in - Sigma.Sigma (of_constr t,sigma,p) + let (evd,t) = Evd.fresh_global ?loc ?rigid ?names env sigma reference in + evd, of_constr t let is_global sigma gr c = Globnames.is_global gr (to_constr sigma c) diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 94b7ca96a..07a4dc8e2 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -259,7 +259,7 @@ val lookup_named_val : variable -> named_context_val -> named_declaration (* XXX Missing Sigma proxy *) val fresh_global : ?loc:Loc.t -> ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env -> - 'r Sigma.t -> Globnames.global_reference -> (t, 'r) Sigma.sigma + Evd.evar_map -> Globnames.global_reference -> Evd.evar_map * t val is_global : Evd.evar_map -> Globnames.global_reference -> t -> bool diff --git a/engine/engine.mllib b/engine/engine.mllib index 1b670d366..afc02d7f6 100644 --- a/engine/engine.mllib +++ b/engine/engine.mllib @@ -2,7 +2,6 @@ Logic_monad Universes UState Evd -Sigma EConstr Namegen Termops diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 59ad4ef47..e8d184632 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -15,7 +15,6 @@ open Namegen open Pre_env open Environ open Evd -open Sigma.Notations module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration @@ -45,8 +44,8 @@ let e_new_global evdref x = EConstr.of_constr (evd_comb1 (Evd.fresh_global (Global.env())) evdref x) let new_global evd x = - let Sigma (c, sigma, p) = Sigma.fresh_global (Global.env()) evd x in - Sigma (EConstr.of_constr c, sigma, p) + let (evd, c) = Evd.fresh_global (Global.env()) evd x in + (evd, EConstr.of_constr c) (****************************************************) (* Expanding/testing/exposing existential variables *) @@ -368,20 +367,17 @@ let push_rel_context_to_named_context env sigma typ = let default_source = Loc.tag @@ Evar_kinds.InternalHole let restrict_evar evd evk filter ?src candidates = - let evd = Sigma.to_evar_map evd in let candidates = Option.map (fun l -> List.map EConstr.Unsafe.to_constr l) candidates in let evd, evk' = Evd.restrict evk filter ?candidates ?src evd in - Sigma.Unsafe.of_pair (evk', Evd.declare_future_goal evk' evd) + Evd.declare_future_goal evk' evd, evk' let new_pure_evar_full evd evi = - let evd = Sigma.to_evar_map evd in let (evd, evk) = Evd.new_evar evd evi in let evd = Evd.declare_future_goal evk evd in - Sigma.Unsafe.of_pair (evk, evd) + (evd, evk) let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) typ = let typ = EConstr.Unsafe.to_constr typ in - let evd = Sigma.to_evar_map evd in let candidates = Option.map (fun l -> List.map EConstr.Unsafe.to_constr l) candidates in let default_naming = Misctypes.IntroAnonymous in let naming = Option.default default_naming naming in @@ -407,19 +403,19 @@ let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?ca if principal then Evd.declare_principal_goal newevk evd else Evd.declare_future_goal newevk evd in - Sigma.Unsafe.of_pair (newevk, evd) + (evd, newevk) let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?principal instance = let open EConstr in assert (not !Flags.debug || List.distinct (ids_of_named_context (named_context_of_val sign))); - let Sigma (newevk, evd, p) = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in - Sigma (mkEvar (newevk,Array.of_list instance), evd, p) + let (evd, newevk) = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in + evd, mkEvar (newevk,Array.of_list instance) (* [new_evar] declares a new existential in an env env with type typ *) (* Converting the env into the sign of the evar to define *) let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = - let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env (Sigma.to_evar_map evd) typ in + let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env evd typ in let map c = subst2 subst vsubst c in let candidates = Option.map (fun l -> List.map map l) candidates in let instance = @@ -428,27 +424,20 @@ let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = | Some filter -> Filter.filter_list filter instance in new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance -let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ = - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in - (Sigma.to_evar_map evd, evk) - let new_type_evar env evd ?src ?filter ?naming ?principal rigid = - let Sigma (s, evd', p) = Sigma.new_sort_variable rigid evd in - let Sigma (e, evd', q) = new_evar env evd' ?src ?filter ?naming ?principal (EConstr.mkSort s) in - Sigma ((e, s), evd', p +> q) + let (evd', s) = new_sort_variable rigid evd in + let (evd', e) = new_evar env evd' ?src ?filter ?naming ?principal (EConstr.mkSort s) in + evd', (e, s) let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid = - let sigma = Sigma.Unsafe.of_evar_map !evdref in - let Sigma (c, sigma, _) = new_type_evar env sigma ?src ?filter ?naming ?principal rigid in - let sigma = Sigma.to_evar_map sigma in - evdref := sigma; + let (evd, c) = new_type_evar env !evdref ?src ?filter ?naming ?principal rigid in + evdref := evd; c let new_Type ?(rigid=Evd.univ_flexible) env evd = let open EConstr in - let Sigma (s, sigma, p) = Sigma.new_sort_variable rigid evd in - Sigma (mkSort s, sigma, p) + let (evd, s) = new_sort_variable rigid evd in + (evd, mkSort s) let e_new_Type ?(rigid=Evd.univ_flexible) env evdref = let evd', s = new_sort_variable rigid !evdref in @@ -456,7 +445,7 @@ let e_new_Type ?(rigid=Evd.univ_flexible) env evdref = (* The same using side-effect *) let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ty = - let (evd',ev) = new_evar_unsafe env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in + let (evd',ev) = new_evar env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in evdref := evd'; ev @@ -552,9 +541,8 @@ let rec check_and_clear_in_constr env evdref err ids global c = else let origfilter = Evd.evar_filter evi in let filter = Evd.Filter.apply_subfilter origfilter filter in - let evd = Sigma.Unsafe.of_evar_map !evdref in - let Sigma (_, evd, _) = restrict_evar evd evk filter None in - let evd = Sigma.to_evar_map evd in + let evd = !evdref in + let (evd,_) = restrict_evar evd evk filter None in evdref := evd; (* spiwack: hacking session to mark the old [evk] as having been "cleared" *) let evi = Evd.find !evdref evk in @@ -723,8 +711,8 @@ let occur_evar_upto sigma n c = let judge_of_new_Type evd = let open EConstr in - let Sigma (s, evd', p) = Sigma.new_univ_variable univ_rigid evd in - Sigma ({ uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }, evd', p) + let (evd', s) = new_univ_variable univ_rigid evd in + (evd', { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }) let subterm_source evk (loc,k) = let evk = match k with diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 496ec5bc4..90c5c3dc0 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -22,18 +22,18 @@ val mk_new_meta : unit -> constr (** {6 Creating a fresh evar given their type and context} *) val new_evar : - env -> 'r Sigma.t -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> + env -> evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> types -> (constr, 'r) Sigma.sigma + ?principal:bool -> types -> evar_map * EConstr.t val new_pure_evar : - named_context_val -> 'r Sigma.t -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> + named_context_val -> evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> types -> (evar, 'r) Sigma.sigma + ?principal:bool -> types -> evar_map * evar -val new_pure_evar_full : 'r Sigma.t -> evar_info -> (evar, 'r) Sigma.sigma +val new_pure_evar_full : evar_map -> evar_info -> evar_map * evar (** the same with side-effects *) val e_new_evar : @@ -45,23 +45,23 @@ val e_new_evar : (** Create a new Type existential variable, as we keep track of them during type-checking and unification. *) val new_type_evar : - env -> 'r Sigma.t -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> + env -> evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> - (constr * sorts, 'r) Sigma.sigma + evar_map * (constr * sorts) val e_new_type_evar : env -> evar_map ref -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> constr * sorts -val new_Type : ?rigid:rigid -> env -> 'r Sigma.t -> (constr, 'r) Sigma.sigma +val new_Type : ?rigid:rigid -> env -> evar_map -> evar_map * constr val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr -val restrict_evar : 'r Sigma.t -> existential_key -> Filter.t -> - ?src:Evar_kinds.t Loc.located -> constr list option -> (existential_key, 'r) Sigma.sigma +val restrict_evar : evar_map -> existential_key -> Filter.t -> + ?src:Evar_kinds.t Loc.located -> constr list option -> evar_map * existential_key (** Polymorphic constants *) -val new_global : 'r Sigma.t -> Globnames.global_reference -> (constr, 'r) Sigma.sigma +val new_global : evar_map -> Globnames.global_reference -> evar_map * constr val e_new_global : evar_map ref -> Globnames.global_reference -> constr (** Create a fresh evar in a context different from its definition context: @@ -71,11 +71,11 @@ val e_new_global : evar_map ref -> Globnames.global_reference -> constr of [inst] are typed in the occurrence context and their type (seen as a telescope) is [sign] *) val new_evar_instance : - named_context_val -> 'r Sigma.t -> types -> + named_context_val -> evar_map -> types -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> - constr list -> (constr, 'r) Sigma.sigma + constr list -> evar_map * constr val make_pure_subst : evar_info -> 'a array -> (Id.t * 'a) list @@ -133,7 +133,7 @@ val occur_evar_upto : evar_map -> Evar.t -> constr -> bool (** {6 Value/Type constraints} *) -val judge_of_new_Type : 'r Sigma.t -> (unsafe_judgment, 'r) Sigma.sigma +val judge_of_new_Type : evar_map -> evar_map * unsafe_judgment (***********************************************************) diff --git a/engine/ftactic.ml b/engine/ftactic.ml index aeaaea7e4..68368e38f 100644 --- a/engine/ftactic.ml +++ b/engine/ftactic.ml @@ -53,31 +53,17 @@ let bind (type a) (type b) (m : a t) (f : a -> b t) : b t = m >>= function Proofview.tclUNIT (Depends filtered) let goals = Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l) -let set_sigma r = - let Sigma.Sigma (ans, sigma, _) = r in - Proofview.Unsafe.tclEVARS (Sigma.to_evar_map sigma) >>= fun () -> ans let nf_enter f = bind goals (fun gl -> gl >>= fun gl -> Proofview.Goal.normalize gl >>= fun nfgl -> - Proofview.V82.wrap_exceptions (fun () -> f.enter nfgl)) - -let nf_s_enter f = - bind goals - (fun gl -> - gl >>= fun gl -> - Proofview.Goal.normalize gl >>= fun nfgl -> - Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter nfgl))) + Proofview.V82.wrap_exceptions (fun () -> f nfgl)) let enter f = bind goals - (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f.enter gl)) - -let s_enter f = - bind goals - (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter gl))) + (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f gl)) let with_env t = t >>= function diff --git a/engine/ftactic.mli b/engine/ftactic.mli index 5db373199..97bebe9da 100644 --- a/engine/ftactic.mli +++ b/engine/ftactic.mli @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Proofview.Notations - (** This module defines potentially focussing tactics. They are used by Ltac to emulate the historical behaviour of always-focussed tactics while still allowing to remain global when the goal is not needed. *) @@ -41,20 +39,13 @@ val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic (** {5 Focussing} *) -val nf_enter : ([ `NF ], 'a t) enter -> 'a t +val nf_enter : ([ `NF ] Proofview.Goal.t -> 'a t) -> 'a t (** Enter a goal. The resulting tactic is focussed. *) -val enter : ([ `LZ ], 'a t) enter -> 'a t +val enter : ([ `LZ ] Proofview.Goal.t -> 'a t) -> 'a t (** Enter a goal, without evar normalization. The resulting tactic is focussed. *) -val s_enter : ([ `LZ ], 'a t) s_enter -> 'a t -(** Enter a goal and put back an evarmap. The resulting tactic is focussed. *) - -val nf_s_enter : ([ `NF ], 'a t) s_enter -> 'a t -(** Enter a goal, without evar normalization and put back an evarmap. The - resulting tactic is focussed. *) - val with_env : 'a t -> (Environ.env*'a) t (** [with_env t] returns, in addition to the return type of [t], an environment, which is the global environment if [t] does not focus on diff --git a/engine/proofview.ml b/engine/proofview.ml index 29bb1ef39..39ef65dab 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -16,7 +16,6 @@ open Pp open Util open Proofview_monad -open Sigma.Notations open Context.Named.Declaration (** Main state of tactics *) @@ -71,10 +70,8 @@ let dependent_init = 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 (gl, _) = EConstr.destEvar (Sigma.to_evar_map sigma) econstr 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 entry = (econstr, typ) :: ret in entry, { solution = sol; comb = gl :: comb; shelf = [] } @@ -1012,20 +1009,17 @@ let catchable_exception = function module Goal = struct - type ('a, 'r) t = { + type 'a t = { env : Environ.env; sigma : Evd.evar_map; 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 assume (gl : 'a t) = (gl :> [ `NF ] t) let env {env} = env - let sigma {sigma} = Sigma.Unsafe.of_evar_map sigma + let sigma {sigma} = sigma let hyps {env} = EConstr.named_context env let concl {concl} = concl let extra {sigma; self} = goal_extra sigma self @@ -1048,7 +1042,7 @@ module Goal = struct 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 @@ -1066,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 -> @@ -1091,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 @@ -1156,8 +1115,6 @@ module Goal = struct (* compatibility *) let goal { self=self } = self - let lift (gl : ('a, 'r) t) _ = (gl :> ('a, 's) t) - end @@ -1281,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 diff --git a/engine/proofview.mli b/engine/proofview.mli index da8a8fecd..aae25b6f8 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -469,67 +469,48 @@ module Goal : sig data using {!assume} if you known you do not rely on the assumption of being normalized, at your own risk. - The second parameter is a stage indicating where the goal belongs. See - module {!Sigma}. *) - type ('a, 'r) t + type 'a t (** Assume that you do not need the goal to be normalized. *) - val assume : ('a, 'r) t -> ([ `NF ], 'r) t + val assume : 'a t -> [ `NF ] t (** Normalises the argument goal. *) - val normalize : ('a, 'r) t -> ([ `NF ], 'r) t tactic + val normalize : 'a t -> [ `NF ] t tactic (** [concl], [hyps], [env] and [sigma] given a goal [gl] return respectively the conclusion of [gl], the hypotheses of [gl], the environment of [gl] (i.e. the global environment and the hypotheses) and the current evar map. *) - val concl : ('a, 'r) t -> constr - val hyps : ('a, 'r) t -> named_context - val env : ('a, 'r) t -> Environ.env - val sigma : ('a, 'r) t -> 'r Sigma.t - val extra : ('a, 'r) t -> Evd.Store.t - - type ('a, 'b) enter = - { enter : 'r. ('a, 'r) t -> 'b } + val concl : 'a t -> constr + val hyps : 'a t -> named_context + val env : 'a t -> Environ.env + val sigma : 'a t -> Evd.evar_map + val extra : 'a t -> Evd.Store.t (** [nf_enter t] applies the goal-dependent tactic [t] in each goal independently, in the manner of {!tclINDEPENDENT} except that the current goal is also given as an argument to [t]. The goal is normalised with respect to evars. *) - val nf_enter : ([ `NF ], unit tactic) enter -> unit tactic + val nf_enter : ([ `NF ] t -> unit tactic) -> unit tactic (** Like {!nf_enter}, but does not normalize the goal beforehand. *) - val enter : ([ `LZ ], unit tactic) enter -> unit tactic + val enter : ([ `LZ ] t -> unit tactic) -> unit tactic (** Like {!enter}, but assumes exactly one goal under focus, raising *) (** an error otherwise. *) - val enter_one : ([ `LZ ], 'a tactic) enter -> 'a tactic - - type ('a, 'b) s_enter = - { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } - - (** A variant of {!enter} allows to work with a monotonic state. The evarmap - returned by the argument is put back into the current state before firing - the returned tactic. *) - val s_enter : ([ `LZ ], unit tactic) s_enter -> unit tactic - - (** Like {!s_enter}, but normalizes the goal beforehand. *) - val nf_s_enter : ([ `NF ], unit tactic) s_enter -> unit tactic + val enter_one : ([ `LZ ] t -> 'a tactic) -> 'a tactic (** Recover the list of current goals under focus, without evar-normalization. FIXME: encapsulate the level in an existential type. *) - val goals : ([ `LZ ], 'r) t tactic list tactic + val goals : [ `LZ ] t tactic list tactic (** [unsolved g] is [true] if [g] is still unsolved in the current proof state. *) - val unsolved : ('a, 'r) t -> bool tactic + val unsolved : 'a t -> bool tactic (** Compatibility: avoid if possible *) - val goal : ([ `NF ], 'r) t -> Evar.t - - (** Every goal is valid at a later stage. FIXME: take a later evarmap *) - val lift : ('a, 'r) t -> ('r, 's) Sigma.le -> ('a, 's) t + val goal : [ `NF ] t -> Evar.t end @@ -616,8 +597,4 @@ module Notations : sig (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) val (<+>) : 'a tactic -> 'a tactic -> 'a tactic - 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 diff --git a/engine/sigma.ml b/engine/sigma.ml deleted file mode 100644 index 001f8be80..000000000 --- a/engine/sigma.ml +++ /dev/null @@ -1,117 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -type 'a t = Evd.evar_map - -type ('a, 'b) le = unit - -let refl = () -let cons _ _ = () -let (+>) = fun _ _ -> () - -type ('a, 'r) sigma = Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma - -type 'a evar = Evar.t - -let lift_evar evk () = evk - -let to_evar_map evd = evd -let to_evar evk = evk - -let here x s = Sigma (x, s, ()) - -(** API *) - -type 'r fresh = Fresh : 's evar * 's t * ('r, 's) le -> 'r fresh - -let new_evar sigma ?name info = - let (sigma, evk) = Evd.new_evar sigma ?name info in - Fresh (evk, sigma, ()) - -let define evk c sigma = - Sigma ((), Evd.define evk c sigma, ()) - -let new_univ_level_variable ?loc ?name rigid sigma = - let (sigma, u) = Evd.new_univ_level_variable ?loc ?name rigid sigma in - Sigma (u, sigma, ()) - -let new_univ_variable ?loc ?name rigid sigma = - let (sigma, u) = Evd.new_univ_variable ?loc ?name rigid sigma in - Sigma (u, sigma, ()) - -let new_sort_variable ?loc ?name rigid sigma = - let (sigma, u) = Evd.new_sort_variable ?loc ?name rigid sigma in - Sigma (u, sigma, ()) - -let fresh_sort_in_family ?loc ?rigid env sigma s = - let (sigma, s) = Evd.fresh_sort_in_family ?loc ?rigid env sigma s in - Sigma (s, sigma, ()) - -let fresh_constant_instance ?loc env sigma cst = - let (sigma, cst) = Evd.fresh_constant_instance ?loc env sigma cst in - Sigma (cst, sigma, ()) - -let fresh_inductive_instance ?loc env sigma ind = - let (sigma, ind) = Evd.fresh_inductive_instance ?loc env sigma ind in - Sigma (ind, sigma, ()) - -let fresh_constructor_instance ?loc env sigma pc = - let (sigma, c) = Evd.fresh_constructor_instance ?loc env sigma pc in - Sigma (c, sigma, ()) - -let fresh_global ?loc ?rigid ?names env sigma r = - let (sigma, c) = Evd.fresh_global ?loc ?rigid ?names env sigma r in - Sigma (c, sigma, ()) - -(** Run *) - -type 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } - -let run sigma f : 'a * Evd.evar_map = - let Sigma (x, sigma, ()) = f.run sigma in - (x, sigma) - -(** Monotonic references *) - -type evdref = Evd.evar_map ref - -let apply evdref f = - let Sigma (x, sigma, ()) = f.run !evdref in - evdref := sigma; - x - -let purify f = - let f (sigma : Evd.evar_map) = - let evdref = ref sigma in - let ans = f evdref in - Sigma (ans, !evdref, ()) - in - { run = f } - -(** Unsafe primitives *) - -module Unsafe = -struct - -let le = () -let of_evar_map sigma = sigma -let of_evar evk = evk -let of_ref ref = ref -let of_pair (x, sigma) = Sigma (x, sigma, ()) - -end - -module Notations = -struct - type ('a, 'r) sigma_ = ('a, 'r) sigma = - Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma_ - - let (+>) = fun _ _ -> () - - type 'a run_ = 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } -end diff --git a/engine/sigma.mli b/engine/sigma.mli deleted file mode 100644 index 8e8df02f2..000000000 --- a/engine/sigma.mli +++ /dev/null @@ -1,131 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Names -open Constr - -(** Monotonous state enforced by typing. - - This module allows to constrain uses of evarmaps in a monotonous fashion, - and in particular statically suppress evar leaks and the like. To this - ends, it defines a type of indexed evarmaps whose phantom typing ensures - monotonous use. -*) - -(** {5 Stages} *) - -type ('a, 'b) le -(** Relationship stating that stage ['a] is anterior to stage ['b] *) - -val refl : ('a, 'a) le -(** Reflexivity of anteriority *) - -val cons : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le -(** Transitivity of anteriority *) - -val (+>) : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le -(** Alias for {!cons} *) - -(** {5 Monotonous evarmaps} *) - -type 'r t -(** Stage-indexed evarmaps. This is just a plain evarmap with a phantom type. *) - -type ('a, 'r) sigma = Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma -(** Return values at a later stage *) - -type 'r evar -(** Stage-indexed evars *) - -(** {5 Constructors} *) - -val here : 'a -> 'r t -> ('a, 'r) sigma -(** [here x s] is a shorthand for [Sigma (x, s, refl)] *) - -(** {5 Postponing} *) - -val lift_evar : 'r evar -> ('r, 's) le -> 's evar -(** Any evar existing at stage ['r] is also valid at any later stage. *) - -(** {5 Downcasting} *) - -val to_evar_map : 'r t -> Evd.evar_map -val to_evar : 'r evar -> Evar.t - -(** {5 Monotonous API} *) - -type 'r fresh = Fresh : 's evar * 's t * ('r, 's) le -> 'r fresh - -val new_evar : 'r t -> ?name:Id.t -> - Evd.evar_info -> 'r fresh - -val define : 'r evar -> Constr.t -> 'r t -> (unit, 'r) sigma - -(** Polymorphic universes *) - -val new_univ_level_variable : ?loc:Loc.t -> ?name:string -> - Evd.rigid -> 'r t -> (Univ.universe_level, 'r) sigma -val new_univ_variable : ?loc:Loc.t -> ?name:string -> - Evd.rigid -> 'r t -> (Univ.universe, 'r) sigma -val new_sort_variable : ?loc:Loc.t -> ?name:string -> - Evd.rigid -> 'r t -> (Sorts.t, 'r) sigma - -val fresh_sort_in_family : ?loc:Loc.t -> ?rigid:Evd.rigid -> Environ.env -> - 'r t -> Term.sorts_family -> (Term.sorts, 'r) sigma -val fresh_constant_instance : - ?loc:Loc.t -> Environ.env -> 'r t -> constant -> (pconstant, 'r) sigma -val fresh_inductive_instance : - ?loc:Loc.t -> Environ.env -> 'r t -> inductive -> (pinductive, 'r) sigma -val fresh_constructor_instance : ?loc:Loc.t -> Environ.env -> 'r t -> constructor -> - (pconstructor, 'r) sigma - -val fresh_global : ?loc:Loc.t -> ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env -> - 'r t -> Globnames.global_reference -> (constr, 'r) sigma - -(** FILLME *) - -(** {5 Run} *) - -type 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } - -val run : Evd.evar_map -> 'a run -> 'a * Evd.evar_map - -(** {5 Imperative monotonic functions} *) - -type evdref -(** Monotonic references over evarmaps *) - -val apply : evdref -> 'a run -> 'a -(** Apply a monotonic function on a reference. *) - -val purify : (evdref -> 'a) -> 'a run -(** Converse of {!apply}. *) - -(** {5 Unsafe primitives} *) - -module Unsafe : -sig - val le : ('a, 'b) le - val of_evar_map : Evd.evar_map -> 'r t - val of_evar : Evd.evar -> 'r evar - val of_ref : Evd.evar_map ref -> evdref - val of_pair : ('a * Evd.evar_map) -> ('a, 'r) sigma -end - -(** {5 Notations} *) - -module Notations : -sig - type ('a, 'r) sigma_ = ('a, 'r) sigma = - Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma_ - - type 'a run_ = 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } - - val (+>) : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le - (** Alias for {!cons} *) -end diff --git a/grammar/argextend.mlp b/grammar/argextend.mlp index 3af63de4d..5068ba8a6 100644 --- a/grammar/argextend.mlp +++ b/grammar/argextend.mlp @@ -137,11 +137,11 @@ let declare_tactic_argument loc s (typ, f, g, h) cl = let typ = match globtyp with None -> ExtraArgType s | Some typ -> typ in <:expr< let f = $lid:f$ in - fun ist v -> Ftactic.nf_s_enter { Proofview.Goal.s_enter = fun gl -> + fun ist v -> Ftactic.nf_enter (fun gl -> let (sigma, v) = Tacmach.New.of_old (fun gl -> f ist gl v) gl in let v = Geninterp.Val.inject (Geninterp.val_tag $make_topwit loc typ$) v in - Sigma.Unsafe.of_pair (Ftactic.return v, sigma) - } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Ftactic.return v) + ) >> in let subst = match h with | None -> diff --git a/intf/tactypes.mli b/intf/tactypes.mli index ef90b911c..5c1d31946 100644 --- a/intf/tactypes.mli +++ b/intf/tactypes.mli @@ -22,8 +22,7 @@ open Misctypes type glob_constr_and_expr = Glob_term.glob_constr * constr_expr option type glob_constr_pattern_and_expr = Id.Set.t * glob_constr_and_expr * constr_pattern -type 'a delayed_open = - { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } +type 'a delayed_open = Environ.env -> Evd.evar_map -> Evd.evar_map * 'a type delayed_open_constr = EConstr.constr delayed_open type delayed_open_constr_with_bindings = EConstr.constr with_bindings delayed_open diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 33a9dd4fd..6281b2675 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -1,5 +1,3 @@ -open Proofview.Notations - let contrib_name = "btauto" let init_constant dir s = @@ -219,7 +217,7 @@ module Btauto = struct Tacticals.tclFAIL 0 msg gl let try_unification env = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let concl = Proofview.Goal.concl gl in let eq = Lazy.force eq in let concl = EConstr.Unsafe.to_constr concl in @@ -232,10 +230,10 @@ module Btauto = struct | _ -> let msg = str "Btauto: Internal error" in Tacticals.New.tclFAIL 0 msg - end } + end let tac = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let concl = Proofview.Goal.concl gl in let concl = EConstr.Unsafe.to_constr concl in let sigma = Tacmach.New.project gl in @@ -262,6 +260,6 @@ module Btauto = struct | _ -> let msg = str "Cannot recognize a boolean equality" in Tacticals.New.tclFAIL 0 msg - end } + end end diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 43c06a54d..b638f2360 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -241,24 +241,20 @@ let app_global f args k = Tacticals.New.pf_constr_of_global (Lazy.force f) >>= fun fc -> k (mkApp (fc, args)) let rec gen_holes env sigma t n accu = - let open Sigma in if Int.equal n 0 then (sigma, List.rev accu) else match EConstr.kind sigma t with | Prod (_, u, t) -> - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (ev, sigma, _) = Evarutil.new_evar env sigma u in - let sigma = Sigma.to_evar_map sigma in + let (sigma, ev) = Evarutil.new_evar env sigma u in let t = EConstr.Vars.subst1 ev t in gen_holes env sigma t (pred n) (ev :: accu) | _ -> assert false let app_global_with_holes f args n = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> Tacticals.New.pf_constr_of_global (Lazy.force f) >>= fun fc -> let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in - Refine.refine { Sigma.run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in + Refine.refine begin fun sigma -> let t = Tacmach.New.pf_get_type_of gl fc in let t = Termops.prod_applist sigma t (Array.to_list args) in let ans = mkApp (fc, args) in @@ -266,32 +262,33 @@ let app_global_with_holes f args n = let ans = applist (ans, holes) in let evdref = ref sigma in let () = Typing.e_check env evdref ans concl in - Sigma.Unsafe.of_pair (ans, !evdref) - end } - end } + (!evdref, ans) + end + end let assert_before n c = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let evm, _ = Tacmach.New.pf_apply type_of gl c in - Sigma.Unsafe.of_pair (assert_before n c, evm) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) + (assert_before n c) + end let refresh_type env evm ty = Evarsolve.refresh_universes ~status:Evd.univ_flexible ~refreshset:true (Some false) env evm ty let refresh_universes ty k = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let evm = Tacmach.New.project gl in let evm, ty = refresh_type env evm ty in - Sigma.Unsafe.of_pair (k ty, evm) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) (k ty) + end let constr_of_term c = EConstr.of_constr (constr_of_term c) let rec proof_tac p : unit Proofview.tactic = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let type_of t = Tacmach.New.pf_unsafe_type_of gl t in try (* type_of can raise exceptions *) match p.p_rule with @@ -354,10 +351,10 @@ let rec proof_tac p : unit Proofview.tactic = Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Tacticals.New.tclTHEN injt (proof_tac prf)))) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e - end } + end let refute_tac c t1 t2 p = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let hid = Tacmach.New.pf_get_new_id (Id.of_string "Heq") gl in let false_t=mkApp (c,[|mkVar hid|]) in @@ -366,16 +363,16 @@ let refute_tac c t1 t2 p = Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) [proof_tac p; simplest_elim false_t] in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt1) k - end } + end let refine_exact_check c = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let evm, _ = Tacmach.New.pf_apply type_of gl c in - Sigma.Unsafe.of_pair (exact_check c, evm) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) (exact_check c) + end let convert_to_goal_tac c t1 t2 p = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let k sort = let neweq= app_global _eq [|sort;tt1;tt2|] in @@ -386,21 +383,21 @@ let convert_to_goal_tac c t1 t2 p = Tacticals.New.tclTHENS (neweq (assert_before (Name e))) [proof_tac p; endt refine_exact_check] in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt2) k - end } + end let convert_to_hyp_tac c1 t1 c2 t2 p = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let tt2=constr_of_term t2 in let h = Tacmach.New.pf_get_new_id (Id.of_string "H") gl in let false_t=mkApp (c2,[|mkVar h|]) in Tacticals.New.tclTHENS (assert_before (Name h) tt2) [convert_to_goal_tac c1 t1 t2 p; simplest_elim false_t] - end } + end (* Essentially [assert (Heq : lhs = rhs) by proof_tac p; discriminate Heq] *) let discriminate_tac cstru p = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let lhs=constr_of_term p.p_lhs and rhs=constr_of_term p.p_rhs in let env = Proofview.Goal.env gl in let evm = Tacmach.New.project gl in @@ -410,7 +407,7 @@ let discriminate_tac cstru p = Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm) (Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) [proof_tac p; Equality.discrHyp hid]) - end } + end (* wrap everything *) @@ -421,7 +418,7 @@ let build_term_to_complete uf pac = (applist (mkConstructU (kn, EInstance.make u), real_args), pac.arity) let cc_tactic depth additionnal_terms = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in Coqlib.check_required_library Coqlib.logic_module_name; let _ = debug (fun () -> Pp.str "Reading subgoal ...") in @@ -477,7 +474,7 @@ let cc_tactic depth additionnal_terms = let ida = EConstr.of_constr ida in let idb = EConstr.of_constr idb in convert_to_hyp_tac ida ta idb tb p - end } + end let cc_fail = Tacticals.New.tclZEROMSG (Pp.str "congruence failed.") @@ -500,17 +497,17 @@ let congruence_tac depth l = let mk_eq f c1 c2 k = Tacticals.New.pf_constr_of_global (Lazy.force f) >>= fun fc -> - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let open Tacmach.New in let evm, ty = pf_apply type_of gl c1 in let evm, ty = Evarsolve.refresh_universes (Some false) (pf_env gl) evm ty in let term = mkApp (fc, [| ty; c1; c2 |]) in let evm, _ = type_of (pf_env gl) evm term in - Sigma.Unsafe.of_pair (k term, evm) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) (k term) + end let f_equal = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let cut_eq c1 c2 = @@ -537,4 +534,4 @@ let f_equal = | Pretype_errors.PretypeError _ | Type_errors.TypeError _ -> Proofview.tclUNIT () | e -> Proofview.tclZERO ~info e end - end } + end diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index bbb9feae2..e3fab6d01 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -15,7 +15,6 @@ open Ground open Goptions open Tacmach.New open Tacticals.New -open Proofview.Notations open Tacinterp open Libnames open Stdarg @@ -84,24 +83,24 @@ let fail_solver=tclFAIL 0 (Pp.str "GTauto failed") let gen_ground_tac flag taco ids bases = let backup= !qflag in Proofview.tclOR begin - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> qflag:=flag; let solver= match taco with Some tac-> tac | None-> snd (default_solver ()) in let startseq k = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let seq=empty_seq !ground_depth in let seq, sigma = extend_with_ref_list (pf_env gl) (project gl) ids seq in let seq, sigma = extend_with_auto_hints (pf_env gl) (project gl) bases seq in - Sigma.Unsafe.of_pair (k seq, sigma) - end } + tclTHEN (Proofview.Unsafe.tclEVARS sigma) (k seq) + end in let result=ground_tac solver startseq in qflag := backup; result - end } + end end (fun (e, info) -> qflag := backup; Proofview.tclZERO ~info e) diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index ab1dd07c1..0fa3089e7 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -14,7 +14,6 @@ open Instances open Term open Tacmach.New open Tacticals.New -open Proofview.Notations let update_flags ()= let predref=ref Names.Cpred.empty in @@ -31,10 +30,10 @@ let update_flags ()= (Names.Id.Pred.full,Names.Cpred.complement !predref) let ground_tac solver startseq = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> update_flags (); let rec toptac skipped seq = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let () = if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 then @@ -127,7 +126,7 @@ let ground_tac solver startseq = end with Heap.EmptyHeap->solver end - end } in + end in let n = List.length (Proofview.Goal.hyps gl) in startseq (fun seq -> wrap n true (toptac []) seq) - end } + end diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 04bca584f..e1d765a42 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -21,7 +21,6 @@ open Formula open Sequent open Names open Misctypes -open Sigma.Notations open Context.Rel.Declaration let compare_instance inst1 inst2= @@ -114,9 +113,7 @@ let mk_open_instance env evmap id idc m t = let rec aux n avoid env evmap decls = if Int.equal n 0 then evmap, decls else let nid=(fresh_id_in_env avoid var_id env) in - let evmap = Sigma.Unsafe.of_evar_map evmap in - let Sigma ((c, _), evmap, _) = Evarutil.new_type_evar env evmap Evd.univ_flexible in - let evmap = Sigma.to_evar_map evmap in + let (evmap, (c, _)) = Evarutil.new_type_evar env evmap Evd.univ_flexible in let decl = LocalAssum (Name nid, c) in aux (n-1) (nid::avoid) (EConstr.push_rel decl env) evmap (decl::decls) in let evmap, decls = aux m [] env evmap [] in @@ -126,7 +123,7 @@ let mk_open_instance env evmap id idc m t = let left_instance_tac (inst,id) continue seq= let open EConstr in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in match inst with Phantom dom-> @@ -137,10 +134,10 @@ let left_instance_tac (inst,id) continue seq= [tclTHENLIST [introf; (pf_constr_of_global id >>= fun idc -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let id0 = List.nth (pf_ids_of_hyps gl) 0 in generalize [mkApp(idc, [|mkVar id0|])] - end }); + end); introf; tclSOLVE [wrap 1 false continue (deepen (record (id,None) seq))]]; @@ -153,7 +150,7 @@ let left_instance_tac (inst,id) continue seq= let special_generalize= if m>0 then (pf_constr_of_global id >>= fun idc -> - Proofview.Goal.s_enter { s_enter = begin fun gl-> + Proofview.Goal.enter begin fun gl-> let (evmap, rc, ot) = mk_open_instance (pf_env gl) (project gl) id idc m t in let gt= it_mkLambda_or_LetIn @@ -162,8 +159,9 @@ let left_instance_tac (inst,id) continue seq= try Typing.type_of (pf_env gl) evmap gt with e when CErrors.noncritical e -> user_err Pp.(str "Untypable instance, maybe higher-order non-prenex quantification") in - Sigma.Unsafe.of_pair (generalize [gt], evmap) - end }) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evmap) + (generalize [gt]) + end) else pf_constr_of_global id >>= fun idc -> generalize [mkApp(idc,[|t|])] in @@ -172,20 +170,20 @@ let left_instance_tac (inst,id) continue seq= introf; tclSOLVE [wrap 1 false continue (deepen (record (id,Some c) seq))]] - end } + end let right_instance_tac inst continue seq= let open EConstr in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> match inst with Phantom dom -> tclTHENS (cut dom) [tclTHENLIST [introf; - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let id0 = List.nth (pf_ids_of_hyps gl) 0 in split (ImplicitBindings [mkVar id0]) - end }; + end; tclSOLVE [wrap 0 true continue (deepen seq)]]; tclTRY assumption] | Real ((0,t),_) -> @@ -193,7 +191,7 @@ let right_instance_tac inst continue seq= (tclSOLVE [wrap 0 true continue (deepen seq)])) | Real ((m,t),_) -> tclFAIL 0 (Pp.str "not implemented ... yet") - end } + end let instance_tac inst= if (snd inst)==dummy_id then @@ -202,9 +200,9 @@ let instance_tac inst= left_instance_tac inst let quantified_tac lf backtrack continue seq = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let insts=give_instances (project gl) lf seq in tclORELSE (tclFIRST (List.map (fun inst->instance_tac inst continue seq) insts)) backtrack - end } + end diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index f745dbeb4..b7fe25a32 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -32,7 +32,7 @@ type lseqtac= global_reference -> seqtac type 'a with_backtracking = tactic -> 'a let wrap n b continue seq = - Proofview.Goal.nf_enter { enter = begin fun gls -> + Proofview.Goal.nf_enter begin fun gls -> Control.check_for_interrupt (); let nc = Proofview.Goal.hyps gls in let env=pf_env gls in @@ -52,7 +52,7 @@ let wrap n b continue seq = let seq2=if b then add_formula env sigma Concl dummy_id (pf_concl gls) seq1 else seq1 in continue seq2 - end } + end let basename_of_global=function VarRef id->id @@ -65,12 +65,12 @@ let clear_global=function (* connection rules *) let axiom_tac t seq = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> try pf_constr_of_global (find_left (project gl) t seq) >>= fun c -> exact_no_check c with Not_found -> tclFAIL 0 (Pp.str "No axiom link") - end } + end let ll_atom_tac a backtrack id continue seq = let open EConstr in @@ -107,7 +107,7 @@ let arrow_tac backtrack continue seq= (* left connectives rules *) let left_and_tac ind backtrack id continue seq = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let n=(construct_nhyps (pf_env gl) ind).(0) in tclIFTHENELSE (tclTHENLIST @@ -116,10 +116,10 @@ let left_and_tac ind backtrack id continue seq = tclDO n intro]) (wrap n false continue seq) backtrack - end } + end let left_or_tac ind backtrack id continue seq = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let v=construct_nhyps (pf_env gl) ind in let f n= tclTHENLIST @@ -130,7 +130,7 @@ let left_or_tac ind backtrack id continue seq = (pf_constr_of_global id >>= simplest_elim) (Array.map f v) backtrack - end } + end let left_false_tac id= Tacticals.New.pf_constr_of_global id >>= simplest_elim @@ -140,7 +140,7 @@ let left_false_tac id= (* We use this function for false, and, or, exists *) let ll_ind_tac (ind,u as indu) largs backtrack id continue seq = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let rcs=ind_hyps (pf_env gl) (project gl) 0 indu largs in let vargs=Array.of_list largs in (* construire le terme H->B, le generaliser etc *) @@ -161,7 +161,7 @@ let ll_ind_tac (ind,u as indu) largs backtrack id continue seq = clear_global id; tclDO lp intro]) (wrap lp false continue seq) backtrack - end } + end let ll_arrow_tac a b c backtrack id continue seq= let open EConstr in @@ -199,7 +199,7 @@ let forall_tac backtrack continue seq= backtrack) let left_exists_tac ind backtrack id continue seq = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let n=(construct_nhyps (pf_env gl) ind).(0) in tclIFTHENELSE (Tacticals.New.pf_constr_of_global id >>= simplest_elim) @@ -207,7 +207,7 @@ let left_exists_tac ind backtrack id continue seq = tclDO n intro; (wrap (n-1) false continue seq)]) backtrack - end } + end let ll_forall_tac prod backtrack id continue seq= tclORELSE @@ -215,12 +215,12 @@ let ll_forall_tac prod backtrack id continue seq= [tclTHENLIST [intro; (pf_constr_of_global id >>= fun idc -> - Proofview.Goal.enter { enter = begin fun gls-> + Proofview.Goal.enter begin fun gls-> let open EConstr in let id0 = List.nth (pf_ids_of_hyps gls) 0 in let term=mkApp(idc,[|mkVar(id0)|]) in tclTHEN (generalize [term]) (clear [id0]) - end }); + end); clear_global id; intro; tclCOMPLETE (wrap 1 false continue (deepen seq))]; @@ -239,9 +239,9 @@ let defined_connectives=lazy AllOccurrences,EvalConstRef (fst (Term.destConst (constant "iff")))] let normalize_evaluables= - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> unfold_in_concl (Lazy.force defined_connectives) <*> tclMAP (fun id -> unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly)) (pf_ids_of_hyps gl) - end } + end diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index a6290cb00..317444cf1 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -469,7 +469,7 @@ exception GoalDone (* Résolution d'inéquations linéaires dans R *) let rec fourier () = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in Coqlib.check_required_library ["Coq";"fourier";"Fourier"]; @@ -633,7 +633,7 @@ let rec fourier () = (* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *) !tac (* ((tclABSTRACT None !tac) gl) *) - end } + end ;; (* diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index c2f705898..fd4962398 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1481,7 +1481,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = tclCOMPLETE( Eauto.eauto_with_bases (true,5) - [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] + [(fun _ sigma -> (sigma, Lazy.force refl_equal))] [Hints.Hint_db.empty empty_transparent_state false] ) ) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index a0eb9e2b2..b8070ff88 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -12,7 +12,6 @@ open Context.Rel.Declaration open Indfun_common open Functional_principles_proofs open Misctypes -open Sigma.Notations module RelDecl = Context.Rel.Declaration @@ -669,11 +668,9 @@ let build_case_scheme fa = let ind = first_fun_kn,funs_indexes in (ind,Univ.Instance.empty)(*FIXME*),prop_sort in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (scheme, sigma, _) = + let (sigma, scheme) = Indrec.build_case_analysis_scheme_default env sigma ind sf in - let sigma = Sigma.to_evar_map sigma in let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in let sorts = (fun (_,_,x) -> diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index bd2ac8c67..d28e0aba0 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -37,9 +37,10 @@ let pr_fun_ind_using_typed prc prlc _ opt_c = match opt_c with | None -> mt () | Some b -> - let (b, _) = Tactics.run_delayed (Global.env ()) Evd.empty b in + let (_, b) = b (Global.env ()) Evd.empty in spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings prc prlc b) + ARGUMENT EXTEND fun_ind_using TYPED AS constr_with_bindings option PRINTED BY pr_fun_ind_using_typed diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index a23c51495..f1a9758e8 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -11,7 +11,6 @@ open Glob_term open Declarations open Misctypes open Decl_kinds -open Sigma.Notations module RelDecl = Context.Rel.Declaration @@ -93,7 +92,7 @@ let functional_induction with_clean c princl pat = in let encoded_pat_as_patlist = List.make (List.length args + List.length c_list - 1) None @ [pat] in - List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr ({ Tacexpr.delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) })),(None,pat),None)) + List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)) )),(None,pat),None)) (args@c_list) encoded_pat_as_patlist in let princ' = Some (princ,bindings) in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index e6f199dba..ff397d2e9 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -42,7 +42,6 @@ open Auto open Eauto open Indfun_common -open Sigma.Notations open Context.Rel.Declaration (* Ugly things which should not be here *) @@ -700,11 +699,9 @@ let mkDestructEq : observe_tclTHENLIST (str "mkDestructEq") [Proofview.V82.of_tactic (generalize new_hyps); (fun g2 -> - let changefun patvars = { run = fun sigma -> - let redfun = pattern_occs [Locus.AllOccurrencesBut [1], expr] in - let Sigma (c, sigma, p) = redfun.Reductionops.e_redfun (pf_env g2) sigma (pf_concl g2) in - Sigma (c, sigma, p) - } in + let changefun patvars sigma = + pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) + in Proofview.V82.of_tactic (change_in_concl None changefun) g2); Proofview.V82.of_tactic (simplest_case expr)]), to_revert @@ -1357,7 +1354,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp (Proofview.V82.of_tactic e_assumption); Eauto.eauto_with_bases (true,5) - [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] + [(fun _ sigma -> (sigma, (Lazy.force refl_equal)))] [Hints.Hint_db.empty empty_transparent_state false] ] ) diff --git a/plugins/ltac/coretactics.ml4 b/plugins/ltac/coretactics.ml4 index 0a13a20a9..ea1660d90 100644 --- a/plugins/ltac/coretactics.ml4 +++ b/plugins/ltac/coretactics.ml4 @@ -16,8 +16,6 @@ open Genredexpr open Stdarg open Extraargs -open Sigma.Notations - DECLARE PLUGIN "coretactics" (** Basic tactics *) @@ -160,12 +158,12 @@ END (** Split *) let rec delayed_list = function -| [] -> { Tacexpr.delayed = fun _ sigma -> Sigma.here [] sigma } +| [] -> fun _ sigma -> (sigma, []) | x :: l -> - { Tacexpr.delayed = fun env sigma -> - let Sigma (x, sigma, p) = x.Tacexpr.delayed env sigma in - let Sigma (l, sigma, q) = (delayed_list l).Tacexpr.delayed env sigma in - Sigma (x :: l, sigma, p +> q) } + fun env sigma -> + let (sigma, x) = x env sigma in + let (sigma, l) = delayed_list l env sigma in + (sigma, x :: l) TACTIC EXTEND split [ "split" ] -> [ Tactics.split_with_bindings false [NoBindings] ] diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index bf84f61a5..7db484d82 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -16,8 +16,6 @@ open Tacexpr open Refiner open Evd open Locus -open Sigma.Notations -open Proofview.Notations open Context.Named.Declaration module NamedDecl = Context.Named.Declaration @@ -81,7 +79,7 @@ let instantiate_tac_by_name id c = let let_evar name typ = let src = (Loc.tag Evar_kinds.GoalEvar) in - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let sigma = ref sigma in @@ -93,17 +91,14 @@ let let_evar name typ = Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env)) | Names.Name id -> id in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (evar, sigma, p) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in - let tac = - (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere) - in - Sigma (tac, sigma, p) - end } + let (sigma, evar) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere) + end let hget_evar n = let open EConstr in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let evl = evar_list sigma concl in @@ -113,5 +108,5 @@ let hget_evar n = let ev = List.nth evl (n-1) in let ev_type = EConstr.existential_type sigma ev in Tactics.change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl)) - end } + end diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index 9726a5b40..8afe3053d 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -24,7 +24,6 @@ open Util open Termops open Equality open Misctypes -open Sigma.Notations open Proofview.Notations DECLARE PLUGIN "extratactics" @@ -80,12 +79,12 @@ let induction_arg_of_quantified_hyp = function ElimOnIdent and not as "constr" *) let mytclWithHoles tac with_evars c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Tacmach.New.pf_env gl in let sigma = Tacmach.New.project gl in let sigma',c = Tactics.force_destruction_arg with_evars env sigma c in Tacticals.New.tclWITHHOLES with_evars (tac with_evars (Some c)) sigma' - end } + end let elimOnConstrWithHoles tac with_evars c = Tacticals.New.tclDELAYEDWITHHOLES with_evars c @@ -115,7 +114,7 @@ END let discrHyp id = Proofview.tclEVARMAP >>= fun sigma -> - discr_main { delayed = fun env sigma -> Sigma.here (EConstr.mkVar id, NoBindings) sigma } + discr_main (fun env sigma -> (sigma, (EConstr.mkVar id, NoBindings))) let injection_main with_evars c = elimOnConstrWithHoles (injClause None) with_evars c @@ -147,7 +146,7 @@ END let injHyp id = Proofview.tclEVARMAP >>= fun sigma -> - injection_main false { delayed = fun env sigma -> Sigma.here (EConstr.mkVar id, NoBindings) sigma } + injection_main false (fun env sigma -> (sigma, (EConstr.mkVar id, NoBindings))) TACTIC EXTEND dependent_rewrite | [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] @@ -354,23 +353,22 @@ let constr_flags () = { Pretyping.expand_evars = true } let refine_tac ist simple with_classes c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let flags = { constr_flags () with Pretyping.use_typeclasses = with_classes } in let expected_type = Pretyping.OfType concl in let c = Pretyping.type_uconstr ~flags ~expected_type ist c in - let update = { run = fun sigma -> - let Sigma (c, sigma, p) = c.delayed env sigma in - Sigma (c, sigma, p) - } in + let update = begin fun sigma -> + c env sigma + end in let refine = Refine.refine ~unsafe:true update in if simple then refine else refine <*> Tactics.New.reduce_after_refine <*> Proofview.shelve_unifiable - end } + end TACTIC EXTEND refine | [ "refine" uconstr(c) ] -> @@ -663,9 +661,8 @@ let subst_hole_with_term occ tc t = open Tacmach let hResolve id c occ t = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let sigma = Sigma.to_evar_map sigma in let env = Termops.clear_named_body id (Proofview.Goal.env gl) in let concl = Proofview.Goal.concl gl in let env_ids = Termops.ids_of_context env in @@ -684,11 +681,9 @@ let hResolve id c occ t = let t_constr = EConstr.of_constr t_constr in let sigma = Evd.merge_universe_context sigma ctx in let t_constr_type = Retyping.get_type_of env sigma t_constr in - let tac = + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (change_concl (mkLetIn (Anonymous,t_constr,t_constr_type,concl))) - in - Sigma.Unsafe.of_pair (tac, sigma) - end } + end let hResolve_auto id c t = let rec resolve_auto n = @@ -726,12 +721,12 @@ END exception Found of unit Proofview.tactic let rewrite_except h = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let hyps = Tacmach.New.pf_ids_of_hyps gl in Tacticals.New.tclMAP (fun id -> if Id.equal id h then Proofview.tclUNIT () else Tacticals.New.tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true true id (mkVar h) false)) hyps - end } + end let refl_equal = @@ -745,29 +740,29 @@ let refl_equal = should be replaced by a call to the tactic but I don't know how to call it before it is defined. *) let mkCaseEq a : unit Proofview.tactic = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let type_of_a = Tacmach.New.pf_unsafe_type_of gl a in Tacticals.New.pf_constr_of_global (delayed_force refl_equal) >>= fun req -> Tacticals.New.tclTHENLIST [Tactics.generalize [(mkApp(req, [| type_of_a; a|]))]; - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in (** FIXME: this looks really wrong. Does anybody really use this tactic? *) - let Sigma (c, _, _) = (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a]).Reductionops.e_redfun env (Sigma.Unsafe.of_evar_map Evd.empty) concl in + let (_, c) = Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env Evd.empty concl in change_concl c - end }; + end; simplest_case a] - end } + end let case_eq_intros_rewrite x = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let n = nb_prod (Tacmach.New.project gl) (Proofview.Goal.concl gl) in (* Pp.msgnl (Printer.pr_lconstr x); *) Tacticals.New.tclTHENLIST [ mkCaseEq x; - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let hyps = Tacmach.New.pf_ids_of_hyps gl in let n' = nb_prod (Tacmach.New.project gl) concl in @@ -776,9 +771,9 @@ let case_eq_intros_rewrite x = Tacticals.New.tclDO (n'-n-1) intro; introduction h; rewrite_except h] - end } + end ] - end } + end let rec find_a_destructable_match sigma t = let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in @@ -802,15 +797,15 @@ let destauto t = with Found tac -> tac let destauto_in id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in (* Pp.msgnl (Printer.pr_lconstr (mkVar id)); *) (* Pp.msgnl (Printer.pr_lconstr (ctype)); *) destauto ctype - end } + end TACTIC EXTEND destauto -| [ "destauto" ] -> [ Proofview.Goal.enter { enter = begin fun gl -> destauto (Proofview.Goal.concl gl) end } ] +| [ "destauto" ] -> [ Proofview.Goal.enter begin fun gl -> destauto (Proofview.Goal.concl gl) end ] | [ "destauto" "in" hyp(id) ] -> [ destauto_in id ] END @@ -822,21 +817,21 @@ END (**********************************************************************) TACTIC EXTEND transparent_abstract -| [ "transparent_abstract" tactic3(t) ] -> [ Proofview.Goal.nf_enter { enter = fun gl -> - Tactics.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) } ] -| [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> [ Proofview.Goal.nf_enter { enter = fun gl -> - Tactics.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) } ] +| [ "transparent_abstract" tactic3(t) ] -> [ Proofview.Goal.nf_enter begin fun gl -> + Tactics.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end ] +| [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> [ Proofview.Goal.nf_enter begin fun gl -> + Tactics.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end ] END (* ********************************************************************* *) let eq_constr x y = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let evd = Tacmach.New.project gl in match EConstr.eq_constr_universes evd x y with | Some _ -> Proofview.tclUNIT () | None -> Tacticals.New.tclFAIL 0 (str "Not equal") - end } + end TACTIC EXTEND constr_eq | [ "constr_eq" constr(x) constr(y) ] -> [ eq_constr x y ] @@ -1082,7 +1077,7 @@ TACTIC EXTEND guard END let decompose l c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let to_ind c = if isInd sigma c then fst (destInd sigma c) @@ -1090,7 +1085,7 @@ let decompose l c = in let l = List.map to_ind l in Elim.h_decompose l c - end } + end TACTIC EXTEND decompose | [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ] diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4 index 50e8255a6..2c2a4b850 100644 --- a/plugins/ltac/g_auto.ml4 +++ b/plugins/ltac/g_auto.ml4 @@ -15,7 +15,6 @@ open Pcoq.Prim open Pcoq.Constr open Pltac open Hints -open Tacexpr open Names DECLARE PLUGIN "g_auto" @@ -49,10 +48,7 @@ let eval_uconstrs ist cs = fail_evar = false; expand_evars = true } in - let map c = { delayed = fun env sigma -> - let Sigma.Sigma (c, sigma, p) = c.delayed env sigma in - Sigma.Sigma (c, sigma, p) - } in + let map c env sigma = c env sigma in List.map (fun c -> map (Pretyping.type_uconstr ~flags ist c)) cs let pr_auto_using_raw _ _ _ = Pptactic.pr_auto_using Ppconstr.pr_constr_expr diff --git a/plugins/ltac/g_class.ml4 b/plugins/ltac/g_class.ml4 index 23ce368ee..dd5307638 100644 --- a/plugins/ltac/g_class.ml4 +++ b/plugins/ltac/g_class.ml4 @@ -102,18 +102,18 @@ let rec eq_constr_mod_evars sigma x y = | _, _ -> compare_constr sigma (fun x y -> eq_constr_mod_evars sigma x y) x y let progress_evars t = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let check = - Proofview.Goal.enter { enter = begin fun gl' -> + Proofview.Goal.enter begin fun gl' -> let sigma = Tacmach.New.project gl' in let newconcl = Proofview.Goal.concl gl' in if eq_constr_mod_evars sigma concl newconcl then Tacticals.New.tclFAIL 0 (Pp.str"No progress made (modulo evars)") else Proofview.tclUNIT () - end } + end in t <*> check - end } + end TACTIC EXTEND progress_evars [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.tactic_of_value ist t) ] diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 index 5adf8475a..25258ffa9 100644 --- a/plugins/ltac/g_rewrite.ml4 +++ b/plugins/ltac/g_rewrite.ml4 @@ -18,7 +18,6 @@ open Glob_term open Geninterp open Extraargs open Tacmach -open Proofview.Notations open Rewrite open Stdarg open Pcoq.Vernac_ @@ -123,7 +122,7 @@ TACTIC EXTEND rewrite_strat END let clsubstitute o c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let is_tac id = match fst (fst (snd c)) with { CAst.v = GVar id' } when Id.equal id' id -> true | _ -> false in let hyps = Tacmach.New.pf_ids_of_hyps gl in Tacticals.New.tclMAP @@ -132,7 +131,7 @@ let clsubstitute o c = | Some id when is_tac id -> Tacticals.New.tclIDTAC | _ -> cl_rewrite_clause c o AllOccurrences cl) (None :: List.map (fun id -> Some id) hyps) - end } + end TACTIC EXTEND substitute | [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ clsubstitute o c ] diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 902985827..9446f9df4 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -1179,11 +1179,10 @@ let declare_extra_genarg_pprule wit (** Registering *) -let run_delayed c = - Sigma.run Evd.empty { Sigma.run = fun sigma -> c.delayed (Global.env ()) sigma } +let run_delayed c = c (Global.env ()) Evd.empty let run_delayed_destruction_arg = function (* HH: Using Evd.empty looks suspicious *) - | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (fst (run_delayed g)) + | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (snd (run_delayed g)) | clear_flag,ElimOnAnonHyp n as x -> x | clear_flag,ElimOnIdent id as x -> x @@ -1203,7 +1202,7 @@ let () = wit_intro_pattern (Miscprint.pr_intro_pattern pr_constr_expr) (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr c)) - (Miscprint.pr_intro_pattern (fun c -> pr_econstr (fst (run_delayed c)))); + (Miscprint.pr_intro_pattern (fun c -> pr_econstr (snd (run_delayed c)))); Genprint.register_print0 wit_clause_dft_concl (pr_clauses (Some true) pr_lident) @@ -1236,11 +1235,11 @@ let () = Genprint.register_print0 wit_bindings (Miscprint.pr_bindings_no_with pr_constr_expr pr_lconstr_expr) (Miscprint.pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) - (fun it -> Miscprint.pr_bindings_no_with pr_econstr pr_leconstr (fst (run_delayed it))); + (fun it -> Miscprint.pr_bindings_no_with pr_econstr pr_leconstr (snd (run_delayed it))); Genprint.register_print0 wit_constr_with_bindings (pr_with_bindings pr_constr_expr pr_lconstr_expr) (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) - (fun it -> pr_with_bindings pr_econstr pr_leconstr (fst (run_delayed it))); + (fun it -> pr_with_bindings pr_econstr pr_leconstr (snd (run_delayed it))); Genprint.register_print0 Tacarg.wit_destruction_arg (pr_destruction_arg pr_constr_expr pr_lconstr_expr) (pr_destruction_arg (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index f028abde9..68dc1fd37 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -33,7 +33,6 @@ open Environ open Termops open EConstr open Libnames -open Sigma.Notations open Proofview.Notations open Context.Named.Declaration @@ -66,9 +65,7 @@ type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) let find_global dir s = let gr = lazy (find_reference dir s) in fun (evd,cstrs) -> - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force gr) in - let evd = Sigma.to_evar_map sigma in + let (evd, c) = Evarutil.new_global evd (Lazy.force gr) in (evd, cstrs), c (** Utility for dealing with polymorphic applications *) @@ -89,9 +86,7 @@ let cstrevars evars = snd evars let new_cstr_evar (evd,cstrs) env t = let s = Typeclasses.set_resolvable Evd.Store.empty false in - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (t, evd', _) = Evarutil.new_evar ~store:s env evd t in - let evd' = Sigma.to_evar_map evd' in + let (evd', t) = Evarutil.new_evar ~store:s env evd t in let ev, _ = destEvar evd' t in (evd', Evar.Set.add ev cstrs), t @@ -176,17 +171,13 @@ end) = struct let proper_type = let l = lazy (Lazy.force proper_class).cl_impl in fun (evd,cstrs) -> - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in - let evd = Sigma.to_evar_map sigma in + let (evd, c) = Evarutil.new_global evd (Lazy.force l) in (evd, cstrs), c let proper_proxy_type = let l = lazy (Lazy.force proper_proxy_class).cl_impl in fun (evd,cstrs) -> - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in - let evd = Sigma.to_evar_map sigma in + let (evd, c) = Evarutil.new_global evd (Lazy.force l) in (evd, cstrs), c let proper_proof env evars carrier relation x = @@ -357,9 +348,7 @@ end) = struct (try let params, args = Array.chop (Array.length args - 2) args in let env' = push_rel_context rels env in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma ((evar, _), evars, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in - let evars = Sigma.to_evar_map evars in + let (evars, (evar, _)) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in let evars, inst = app_poly env (evars,Evar.Set.empty) rewrite_relation_class [| evar; mkApp (c, params) |] in @@ -419,9 +408,7 @@ module TypeGlobal = struct let inverse env (evd,cstrs) car rel = - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (sort, sigma, _) = Evarutil.new_Type ~rigid:Evd.univ_flexible env sigma in - let evd = Sigma.to_evar_map sigma in + let (evd, sort) = Evarutil.new_Type ~rigid:Evd.univ_flexible env evd in app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |] end @@ -751,9 +738,9 @@ let default_flags = { under_lambdas = true; on_morphisms = true; } let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None -let new_global (evars, cstrs) gr = - let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map evars) gr - in (Sigma.to_evar_map sigma, cstrs), c +let new_global (evars, cstrs) gr = + let (sigma,c) = Evarutil.new_global evars gr in + (sigma, cstrs), c let make_eq sigma = new_global sigma (Coqlib.build_coq_eq ()) @@ -1406,15 +1393,14 @@ module Strategies = let reduce (r : Redexpr.red_expr) : 'a pure_strategy = { strategy = fun { state = state ; env = env ; term1 = t ; ty1 = ty ; cstr = cstr ; evars = evars } -> let rfn, ckind = Redexpr.reduction_of_red_expr env r in - let sigma = Sigma.Unsafe.of_evar_map (goalevars evars) in - let Sigma (t', sigma, _) = rfn.Reductionops.e_redfun env sigma t in - let evars' = Sigma.to_evar_map sigma in - if Termops.eq_constr evars' t' t then + let sigma = goalevars evars in + let (sigma, t') = rfn env sigma t in + if Termops.eq_constr sigma t' t then state, Identity else state, Success { rew_car = ty; rew_from = t; rew_to = t'; rew_prf = RewCast ckind; - rew_evars = evars', cstrevars evars } + rew_evars = sigma, cstrevars evars } } let fold_glob c : 'a pure_strategy = { strategy = @@ -1541,7 +1527,7 @@ let rec insert_dependent env sigma decl accu hyps = match hyps with insert_dependent env sigma decl (ndecl :: accu) rem let assert_replacing id newt tac = - let prf = Proofview.Goal.enter { enter = begin fun gl -> + let prf = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -1552,17 +1538,17 @@ let assert_replacing id newt tac = | d :: rem -> insert_dependent env sigma (LocalAssum (NamedDecl.get_id d, newt)) [] after @ rem in let env' = Environ.reset_with_named_context (val_of_named_context nc) env in - Refine.refine ~unsafe:false { run = begin fun sigma -> - let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma concl in - let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma newt in + Refine.refine ~unsafe:false begin fun sigma -> + let (sigma, ev) = Evarutil.new_evar env' sigma concl in + let (sigma, ev') = Evarutil.new_evar env sigma newt in let map d = let n = NamedDecl.get_id d in if Id.equal n id then ev' else mkVar n in - let (e, _) = destEvar (Sigma.to_evar_map sigma) ev in - Sigma (mkEvar (e, Array.map_of_list map nc), sigma, p +> q) - end } - end } in + let (e, _) = destEvar sigma ev in + (sigma, mkEvar (e, Array.map_of_list map nc)) + end + end in Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) let newfail n s = @@ -1586,7 +1572,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = match clause, prf with | Some id, Some p -> let tac = tclTHENLIST [ - Refine.refine ~unsafe:false { run = fun h -> Sigma.here p h }; + Refine.refine ~unsafe:false (fun h -> (h,p)); Proofview.Unsafe.tclNEWGOALS gls; ] in Proofview.Unsafe.tclEVARS undef <*> @@ -1597,19 +1583,19 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = beta_hyp id | None, Some p -> Proofview.Unsafe.tclEVARS undef <*> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in - let make = { run = begin fun sigma -> - let Sigma (ev, sigma, q) = Evarutil.new_evar env sigma newt in - Sigma (mkApp (p, [| ev |]), sigma, q) - end } in + let make = begin fun sigma -> + let (sigma, ev) = Evarutil.new_evar env sigma newt in + (sigma, mkApp (p, [| ev |])) + end in Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls - end } + end | None, None -> Proofview.Unsafe.tclEVARS undef <*> convert_concl_no_check newt DEFAULTcast in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -1637,7 +1623,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = with | PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) -> raise (RewriteFailure (Himsg.explain_pretype_error env evd e)) - end } + end let tactic_init_setoid () = try init_setoid (); Proofview.tclUNIT () @@ -2092,7 +2078,7 @@ let general_rewrite_flags = { under_lambdas = false; on_morphisms = true } (** Setoid rewriting when called with "rewrite" *) let general_s_rewrite cl l2r occs (c,l) ~new_goals = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let abs, evd, res, sort = get_hyp gl (c,l) cl l2r in let unify env evars t = unify_abs res l2r sort env evars t in let app = apply_rule unify occs in @@ -2114,7 +2100,7 @@ let general_s_rewrite cl l2r occs (c,l) ~new_goals = | RewriteFailure e -> tclFAIL 0 (str"setoid rewrite failed: " ++ e) | e -> Proofview.tclZERO ~info e) - end } + end let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite @@ -2126,7 +2112,7 @@ let not_declared env sigma ty rel = str ty ++ str" relation. Maybe you need to require the Coq.Classes.RelationClasses library") let setoid_proof ty fn fallback = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in @@ -2155,7 +2141,7 @@ let setoid_proof ty fn fallback = | e' -> Proofview.tclZERO ~info e' end end - end } + end let tac_open ((evm,_), c) tac = (tclTHEN (Proofview.Unsafe.tclEVARS evm) (tac c)) @@ -2195,7 +2181,7 @@ let setoid_transitivity c = let setoid_symmetry_in id = let open Tacmach.New in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in let ctype = pf_unsafe_type_of gl (mkVar id) in let binders,concl = decompose_prod_assum sigma ctype in @@ -2212,7 +2198,7 @@ let setoid_symmetry_in id = (tclTHENLAST (Tactics.assert_after_replacing id new_hyp) (tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ])) - end } + end let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity let _ = Hook.set Tactics.setoid_symmetry setoid_symmetry diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index b78dc3742..cfb698cd8 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -117,8 +117,7 @@ type open_glob_constr = unit * glob_constr_and_expr type binding_bound_vars = Constr_matching.binding_bound_vars type glob_constr_pattern_and_expr = binding_bound_vars * glob_constr_and_expr * constr_pattern -type 'a delayed_open = 'a Tactypes.delayed_open = - { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } +type 'a delayed_open = Environ.env -> Evd.evar_map -> Evd.evar_map * 'a type delayed_open_constr_with_bindings = EConstr.constr with_bindings delayed_open diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 37fdd185e..ff76d06cf 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -37,7 +37,6 @@ open Misctypes open Locus open Tacintern open Taccoerce -open Sigma.Notations open Proofview.Notations open Context.Named.Declaration @@ -767,9 +766,7 @@ let interp_may_eval f ist env sigma = function let (sigma,redexp) = interp_red_expr ist env sigma r in let (sigma,c_interp) = f ist env sigma c in let (redfun, _) = Redexpr.reduction_of_red_expr env redexp in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (c, sigma, _) = redfun.Reductionops.e_redfun env sigma c_interp in - (Sigma.to_evar_map sigma, c) + redfun env sigma c_interp | ConstrContext ((loc,s),c) -> (try let (sigma,ic) = f ist env sigma c in @@ -829,12 +826,12 @@ let rec message_of_value v = Ftactic.return (str "<tactic>") else if has_type v (topwit wit_constr) then let v = out_gen (topwit wit_constr) v in - Ftactic.enter {enter = begin fun gl -> Ftactic.return (pr_econstr_env (pf_env gl) (project gl) v) end } + Ftactic.enter begin fun gl -> Ftactic.return (pr_econstr_env (pf_env gl) (project gl) v) end else if has_type v (topwit wit_constr_under_binders) then let c = out_gen (topwit wit_constr_under_binders) v in - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> Ftactic.return (pr_constr_under_binders_env (pf_env gl) (project gl) c) - end } + end else if has_type v (topwit wit_unit) then Ftactic.return (str "()") else if has_type v (topwit wit_int) then @@ -842,24 +839,24 @@ let rec message_of_value v = else if has_type v (topwit wit_intro_pattern) then let p = out_gen (topwit wit_intro_pattern) v in let print env sigma c = - let (c, sigma) = Tactics.run_delayed env sigma c in + let (sigma, c) = c env sigma in pr_econstr_env env sigma c in - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (project gl) c) p) - end } + end else if has_type v (topwit wit_constr_context) then let c = out_gen (topwit wit_constr_context) v in - Ftactic.enter { enter = begin fun gl -> Ftactic.return (pr_econstr_env (pf_env gl) (project gl) c) end } + Ftactic.enter begin fun gl -> Ftactic.return (pr_econstr_env (pf_env gl) (project gl) c) end else if has_type v (topwit wit_uconstr) then let c = out_gen (topwit wit_uconstr) v in - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> Ftactic.return (pr_closed_glob_env (pf_env gl) (project gl) c) - end } + end else if has_type v (topwit wit_var) then let id = out_gen (topwit wit_var) v in - Ftactic.enter { enter = begin fun gl -> Ftactic.return (pr_id id) end } + Ftactic.enter begin fun gl -> Ftactic.return (pr_id id) end else match Value.to_list v with | Some l -> Ftactic.List.map message_of_value l >>= fun l -> @@ -905,11 +902,7 @@ and interp_intro_pattern_action ist env sigma = function let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in sigma, IntroInjection l | IntroApplyOn ((loc,c),ipat) -> - let c = { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_open_constr ist env sigma c in - Sigma.Unsafe.of_pair (c, sigma) - } in + let c env sigma = interp_open_constr ist env sigma c in let sigma,ipat = interp_intro_pattern ist env sigma ipat in sigma, IntroApplyOn ((loc,c),ipat) | IntroWildcard | IntroRewrite _ as x -> sigma, x @@ -1003,21 +996,15 @@ let interp_open_constr_with_bindings_loc ist ((c,_),bl as cb) = let loc1 = loc_of_glob_constr c in let loc2 = loc_of_bindings bl in let loc = Loc.merge_opt loc1 loc2 in - let f = { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_open_constr_with_bindings ist env sigma cb in - Sigma.Unsafe.of_pair (c, sigma) - } in - (loc,f) + let f env sigma = interp_open_constr_with_bindings ist env sigma cb in + (loc,f) let interp_destruction_arg ist gl arg = match arg with | keep,ElimOnConstr c -> - keep,ElimOnConstr { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_open_constr_with_bindings ist env sigma c in - Sigma.Unsafe.of_pair (c, sigma) - } + keep,ElimOnConstr begin fun env sigma -> + interp_open_constr_with_bindings ist env sigma c + end | keep,ElimOnAnonHyp n as x -> x | keep,ElimOnIdent (loc,id) -> let error () = user_err ?loc @@ -1028,12 +1015,12 @@ let interp_destruction_arg ist gl arg = if Tactics.is_quantified_hypothesis id' gl then keep,ElimOnIdent (loc,id') else - (keep, ElimOnConstr { delayed = begin fun env sigma -> - try Sigma.here (constr_of_id env id', NoBindings) sigma + (keep, ElimOnConstr begin fun env sigma -> + try (sigma, (constr_of_id env id', NoBindings)) with Not_found -> user_err ?loc ~hdr:"interp_destruction_arg" ( pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis.") - end }) + end) in try (** FIXME: should be moved to taccoerce *) @@ -1051,18 +1038,17 @@ let interp_destruction_arg ist gl arg = keep,ElimOnAnonHyp (out_gen (topwit wit_int) v) else match Value.to_constr v with | None -> error () - | Some c -> keep,ElimOnConstr { delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) } + | Some c -> keep,ElimOnConstr (fun env sigma -> (sigma, (c,NoBindings))) with Not_found -> (* We were in non strict (interactive) mode *) if Tactics.is_quantified_hypothesis id gl then keep,ElimOnIdent (loc,id) else let c = (CAst.make ?loc @@ GVar id,Some (CAst.make @@ CRef (Ident (loc,id),None))) in - let f = { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in + let f env sigma = let (sigma,c) = interp_open_constr ist env sigma c in - Sigma.Unsafe.of_pair ((c,NoBindings), sigma) - } in + (sigma, (c,NoBindings)) + in keep,ElimOnConstr f (* Associates variables with values and gives the remaining variables and @@ -1198,9 +1184,9 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac)) end | TacAbstract (tac,ido) -> - Proofview.Goal.enter { enter = begin fun gl -> Tactics.tclABSTRACT + Proofview.Goal.enter begin fun gl -> Tactics.tclABSTRACT (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist tac) - end } + end | TacThen (t1,t) -> Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t) | TacDispatch tl -> @@ -1318,12 +1304,13 @@ and interp_tacarg ist arg : Val.t Ftactic.t = | TacGeneric arg -> interp_genarg ist arg | Reference r -> interp_ltac_reference false ist r | ConstrMayEval c -> - Ftactic.s_enter { s_enter = begin fun gl -> + Ftactic.enter begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in - Sigma.Unsafe.of_pair (Ftactic.return (Value.of_constr c_interp), sigma) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Ftactic.return (Value.of_constr c_interp)) + end | TacCall (loc,(r,[])) -> interp_ltac_reference true ist r | TacCall (loc,(f,l)) -> @@ -1332,18 +1319,19 @@ and interp_tacarg ist arg : Val.t Ftactic.t = Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs -> interp_app loc ist fv largs | TacFreshId l -> - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> let id = interp_fresh_id ist (pf_env gl) (project gl) l in Ftactic.return (in_gen (topwit wit_intro_pattern) (Loc.tag @@ IntroNaming (IntroIdentifier id))) - end } + end | TacPretype c -> - Ftactic.s_enter { s_enter = begin fun gl -> + Ftactic.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let c = interp_uconstr ist env (Sigma.to_evar_map sigma) c in - let Sigma (c, sigma, p) = (type_uconstr ist c).delayed env sigma in - Sigma (Ftactic.return (Value.of_constr c), sigma, p) - end } + let c = interp_uconstr ist env sigma c in + let (sigma, c) = type_uconstr ist c env sigma in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Ftactic.return (Value.of_constr c)) + end | TacNumgoals -> Ftactic.lift begin let open Proofview.Notations in @@ -1504,16 +1492,16 @@ and interp_match ist lz constr lmr = Proofview.tclZERO ~info e end end >>= fun constr -> - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr) - end } + end (* Interprets the Match Context expressions *) and interp_match_goal ist lz lr lmr = - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in let hyps = Proofview.Goal.hyps gl in @@ -1521,7 +1509,7 @@ and interp_match_goal ist lz lr lmr = let concl = Proofview.Goal.concl gl in let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in interp_match_successes lz ist (Tactic_matching.match_goal env sigma hyps concl ilr) - end } + end (* Interprets extended tactic generic arguments *) and interp_genarg ist x : Val.t Ftactic.t = @@ -1558,24 +1546,25 @@ and interp_genarg ist x : Val.t Ftactic.t = independently of goals. *) and interp_genarg_constr_list ist x = - Ftactic.nf_s_enter { s_enter = begin fun gl -> + Ftactic.nf_enter begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let sigma = Proofview.Goal.sigma gl in let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in let (sigma,lc) = interp_constr_list ist env sigma lc in let lc = in_list (val_tag wit_constr) lc in - Sigma.Unsafe.of_pair (Ftactic.return lc, sigma) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Ftactic.return lc) + end and interp_genarg_var_list ist x = - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let sigma = Proofview.Goal.sigma gl in let lc = Genarg.out_gen (glbwit (wit_list wit_var)) x in let lc = interp_hyp_list ist env sigma lc in let lc = in_list (val_tag wit_var) lc in Ftactic.return lc - end } + end (* Interprets tactic expressions : returns a "constr" *) and interp_ltac_constr ist e : EConstr.t Ftactic.t = @@ -1584,7 +1573,7 @@ and interp_ltac_constr ist e : EConstr.t Ftactic.t = (val_interp ist e) begin function (err, info) -> match err with | Not_found -> - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> let env = Proofview.Goal.env gl in Proofview.tclLIFT begin debugging_step ist (fun () -> @@ -1592,11 +1581,11 @@ and interp_ltac_constr ist e : EConstr.t Ftactic.t = Pptactic.pr_glob_tactic env e) end <*> Proofview.tclZERO Not_found - end } + end | err -> Proofview.tclZERO ~info err end end >>= fun result -> - Ftactic.enter { enter = begin fun gl -> + Ftactic.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let result = Value.normalize result in @@ -1613,7 +1602,7 @@ and interp_ltac_constr ist e : EConstr.t Ftactic.t = let env = Proofview.Goal.env gl in Tacticals.New.tclZEROMSG (str "Must evaluate to a closed term" ++ fnl() ++ str "offending expression: " ++ fnl() ++ pr_inspect env e result) - end } + end (* Interprets tactic expressions : returns a "tactic" *) @@ -1635,7 +1624,7 @@ and interp_atomic ist tac : unit Proofview.tactic = match tac with (* Basic tactics *) | TacIntroPattern (ev,l) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in @@ -1645,11 +1634,11 @@ and interp_atomic ist tac : unit Proofview.tactic = (* spiwack: print uninterpreted, not sure if it is the expected behaviour. *) (Tactics.intro_patterns ev l')) sigma - end } + end | TacApply (a,ev,cb,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<apply>") begin - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let l = List.map (fun (k,c) -> @@ -1662,10 +1651,10 @@ and interp_atomic ist tac : unit Proofview.tactic = let sigma,(id,cl) = interp_in_hyp_as ist env sigma cl in sigma, Tactics.apply_delayed_in a ev id l cl in Tacticals.New.tclWITHHOLES ev tac sigma - end } + end end | TacElim (ev,(keep,cb),cbo) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let sigma, cb = interp_open_constr_with_bindings ist env sigma cb in @@ -1675,9 +1664,9 @@ and interp_atomic ist tac : unit Proofview.tactic = name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac in Tacticals.New.tclWITHHOLES ev named_tac sigma - end } + end | TacCase (ev,(keep,cb)) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in let sigma, cb = interp_open_constr_with_bindings ist env sigma cb in @@ -1686,11 +1675,11 @@ and interp_atomic ist tac : unit Proofview.tactic = name_atomic ~env (TacCase(ev,(keep,cb))) tac in Tacticals.New.tclWITHHOLES ev named_tac sigma - end } + end | TacMutualFix (id,n,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual fix>") begin - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let env = pf_env gl in let f sigma (id,n,c) = let (sigma,c_interp) = interp_type ist env sigma c in @@ -1698,14 +1687,14 @@ and interp_atomic ist tac : unit Proofview.tactic = let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) in - let tac = Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0 in - Sigma.Unsafe.of_pair (tac, sigma) - end } + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0) + end end | TacMutualCofix (id,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual cofix>") begin - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let env = pf_env gl in let f sigma (id,c) = let (sigma,c_interp) = interp_type ist env sigma c in @@ -1713,12 +1702,12 @@ and interp_atomic ist tac : unit Proofview.tactic = let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) in - let tac = Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0 in - Sigma.Unsafe.of_pair (tac, sigma) - end } + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0) + end end | TacAssert (ev,b,t,ipat,c) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let (sigma,c) = @@ -1733,9 +1722,9 @@ and interp_atomic ist tac : unit Proofview.tactic = (name_atomic ~env (TacAssert(ev,b,Option.map (Option.map ignore) t,ipat,c)) (Tactics.forward b tac ipat' c)) sigma - end } + end | TacGeneralize cl -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in @@ -1743,9 +1732,9 @@ and interp_atomic ist tac : unit Proofview.tactic = (name_atomic ~env (TacGeneralize cl) (Tactics.generalize_gen cl)) sigma - end } + end | TacLetTac (ev,na,c,clp,b,eqpat) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let clp = interp_clause ist env sigma clp in @@ -1777,13 +1766,13 @@ and interp_atomic ist tac : unit Proofview.tactic = (Tacticals.New.tclWITHHOLES ev (let_pat_tac b (interp_name ist env sigma na) (sigma,c) clp eqpat) sigma') - end } + end (* Derived basic tactics *) | TacInductionDestruct (isrec,ev,(l,el)) -> (* spiwack: some unknown part of destruct needs the goal to be prenormalised. *) - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let sigma,l = @@ -1802,23 +1791,23 @@ and interp_atomic ist tac : unit Proofview.tactic = let l,lp = List.split l in let sigma,el = Option.fold_map (interp_open_constr_with_bindings ist env) sigma el in - let tac = name_atomic ~env + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (name_atomic ~env (TacInductionDestruct(isrec,ev,(lp,el))) - (Tactics.induction_destruct isrec ev (l,el)) - in - Sigma.Unsafe.of_pair (tac, sigma) - end } + (Tactics.induction_destruct isrec ev (l,el))) + end (* Conversion *) | TacReduce (r,cl) -> - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in - Sigma.Unsafe.of_pair (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl), sigma) - end } + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl)) + end | TacChange (None,c,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let is_onhyps = match cl.onhyps with | None | Some [] -> true | _ -> false @@ -1827,58 +1816,50 @@ and interp_atomic ist tac : unit Proofview.tactic = | AllOccurrences | NoOccurrences -> true | _ -> false in - let c_interp patvars = { Sigma.run = begin fun sigma -> + let c_interp patvars sigma = let lfun' = Id.Map.fold (fun id c lfun -> Id.Map.add id (Value.of_constr c) lfun) patvars ist.lfun in - let sigma = Sigma.to_evar_map sigma in let ist = { ist with lfun = lfun' } in - let (sigma, c) = if is_onhyps && is_onconcl then interp_type ist (pf_env gl) sigma c else interp_constr ist (pf_env gl) sigma c - in - Sigma.Unsafe.of_pair (c, sigma) - end } in + in Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl) - end } + end end | TacChange (Some op,c,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let op = interp_typed_pattern ist env sigma op in let to_catch = function Not_found -> true | e -> CErrors.is_anomaly e in - let c_interp patvars = { Sigma.run = begin fun sigma -> + let c_interp patvars sigma = let lfun' = Id.Map.fold (fun id c lfun -> Id.Map.add id (Value.of_constr c) lfun) patvars ist.lfun in let ist = { ist with lfun = lfun' } in try - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_constr ist env sigma c in - Sigma.Unsafe.of_pair (c, sigma) + interp_constr ist env sigma c with e when to_catch e (* Hack *) -> user_err (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") - end } in + in Tactics.change (Some op) c_interp (interp_clause ist env sigma cl) - end } + end end (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let l' = List.map (fun (b,m,(keep,c)) -> - let f = { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_open_constr_with_bindings ist env sigma c in - Sigma.Unsafe.of_pair (c, sigma) - } in + let f env sigma = + interp_open_constr_with_bindings ist env sigma c + in (b,m,keep,f)) l in let env = Proofview.Goal.env gl in let sigma = project gl in @@ -1889,9 +1870,9 @@ and interp_atomic ist tac : unit Proofview.tactic = (Option.map (fun by -> Tacticals.New.tclCOMPLETE (interp_tactic ist by), Equality.Naive) by)) - end } + end | TacInversion (DepInversion (k,c,ids),hyp) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let (sigma,c_interp) = @@ -1907,9 +1888,9 @@ and interp_atomic ist tac : unit Proofview.tactic = (name_atomic ~env (TacInversion(DepInversion(k,c_interp,ids),dqhyps)) (Inv.dinv k c_interp ids_interp dqhyps)) sigma - end } + end | TacInversion (NonDepInversion (k,idl,ids),hyp) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let hyps = interp_hyp_list ist env sigma idl in @@ -1919,20 +1900,19 @@ and interp_atomic ist tac : unit Proofview.tactic = (name_atomic ~env (TacInversion (NonDepInversion (k,hyps,ids),dqhyps)) (Inv.inv_clause k ids_interp hyps dqhyps)) sigma - end } + end | TacInversion (InversionUsing (c,idl),hyp) -> - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let (sigma,c_interp) = interp_constr ist env sigma c in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in let hyps = interp_hyp_list ist env sigma idl in - let tac = name_atomic ~env + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (name_atomic ~env (TacInversion (InversionUsing (c_interp,hyps),dqhyps)) - (Leminv.lemInv_clause dqhyps c_interp hyps) - in - Sigma.Unsafe.of_pair (tac, sigma) - end } + (Leminv.lemInv_clause dqhyps c_interp hyps)) + end (* Initial call for interpretation *) @@ -1953,7 +1933,7 @@ let eval_tactic_ist ist t = let interp_tac_gen lfun avoid_ids debug t = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let extra = TacStore.set TacStore.empty f_debug debug in let extra = TacStore.set extra f_avoid_ids avoid_ids in @@ -1961,7 +1941,7 @@ let interp_tac_gen lfun avoid_ids debug t = let ltacvars = Id.Map.domain lfun in interp_tactic ist (intern_pure_tactic { (Genintern.empty_glob_sign env) with ltacvars } t) - end } + end let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t @@ -1980,9 +1960,9 @@ let hide_interp global t ot = Proofview.tclENV >>= fun env -> hide_interp env else - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> hide_interp (Proofview.Goal.env gl) - end } + end (***************************************************************************) (** Register standard arguments *) @@ -2015,37 +1995,35 @@ let () = let () = declare_uniform wit_string -let lift f = (); fun ist x -> Ftactic.enter { enter = begin fun gl -> +let lift f = (); fun ist x -> Ftactic.enter begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let sigma = Proofview.Goal.sigma gl in Ftactic.return (f ist env sigma x) -end } +end -let lifts f = (); fun ist x -> Ftactic.nf_s_enter { s_enter = begin fun gl -> +let lifts f = (); fun ist x -> Ftactic.nf_enter begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let sigma = Proofview.Goal.sigma gl in let (sigma, v) = f ist env sigma x in - Sigma.Unsafe.of_pair (Ftactic.return v, sigma) -end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Ftactic.return v) +end -let interp_bindings' ist bl = Ftactic.return { delayed = fun env sigma -> - let (sigma, bl) = interp_bindings ist env (Sigma.to_evar_map sigma) bl in - Sigma.Unsafe.of_pair (bl, sigma) - } +let interp_bindings' ist bl = Ftactic.return begin fun env sigma -> + interp_bindings ist env sigma bl + end -let interp_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigma -> - let (sigma, c) = interp_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in - Sigma.Unsafe.of_pair (c, sigma) - } +let interp_constr_with_bindings' ist c = Ftactic.return begin fun env sigma -> + interp_constr_with_bindings ist env sigma c + end -let interp_open_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigma -> - let (sigma, c) = interp_open_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in - Sigma.Unsafe.of_pair (c, sigma) - } +let interp_open_constr_with_bindings' ist c = Ftactic.return begin fun env sigma -> + interp_open_constr_with_bindings ist env sigma c + end -let interp_destruction_arg' ist c = Ftactic.enter { enter = begin fun gl -> +let interp_destruction_arg' ist c = Ftactic.enter begin fun gl -> Ftactic.return (interp_destruction_arg ist gl c) -end } +end let interp_pre_ident ist env sigma s = s |> Id.of_string |> interp_ident ist env sigma |> Id.to_string @@ -2078,9 +2056,9 @@ let () = register_interp0 wit_ltac interp let () = - register_interp0 wit_uconstr (fun ist c -> Ftactic.enter { enter = begin fun gl -> + register_interp0 wit_uconstr (fun ist c -> Ftactic.enter begin fun gl -> Ftactic.return (interp_uconstr ist (Proofview.Goal.env gl) (Tacmach.New.project gl) c) - end }) + end) (***************************************************************************) (* Other entry points *) @@ -2111,7 +2089,7 @@ let _ = let dummy_id = Id.of_string "_" let lift_constr_tac_to_ml_tac vars tac = - let tac _ ist = Proofview.Goal.enter { enter = begin fun gl -> + let tac _ ist = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let map = function @@ -2124,7 +2102,7 @@ let lift_constr_tac_to_ml_tac vars tac = in let args = List.map_filter map vars in tac args ist - end } in + end in tac let vernac_debug b = diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 294cba4d7..e6d0370f3 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -12,7 +12,6 @@ open Pp open Tacexpr open Termops open Nameops -open Proofview.Notations let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make () @@ -57,10 +56,10 @@ let db_pr_goal gl = str" " ++ pc) ++ fnl () let db_pr_goal = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let pg = db_pr_goal gl in Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) - end } + end (* Prints the commands *) diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 7497aae3c..83f374346 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1668,8 +1668,6 @@ let rcst_domain_spec = lazy { dump_proof = dump_psatz coq_Q dump_q } -open Proofview.Notations - (** Naive topological sort of constr according to the subterm-ordering *) (* An element is minimal x is minimal w.r.t y if @@ -1712,7 +1710,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in let vm = dump_varmap (spec.typ) (vm_of_list env) in (* todo : directly generate the proof term - or generalize before conversion? *) - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> Tacticals.New.tclTHENLIST [ Tactics.change_concl @@ -1724,7 +1722,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* ] (Tacmach.New.pf_concl gl)) ] - end } + end (** @@ -1972,7 +1970,7 @@ let micromega_gen (normalise:'cst atom -> 'cst mc_cnf) unsat deduce spec dumpexpr prover tac = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Tacmach.New.pf_concl gl in let hyps = Tacmach.New.pf_hyps_types gl in @@ -2029,7 +2027,7 @@ let micromega_gen ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end } + end let micromega_gen parse_arith (negate:'cst atom -> 'cst mc_cnf) @@ -2050,7 +2048,7 @@ let micromega_order_changer cert env ff = let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in let vm = dump_varmap (typ) (vm_of_list env) in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> Tacticals.New.tclTHENLIST [ (Tactics.change_concl @@ -2065,7 +2063,7 @@ let micromega_order_changer cert env ff = (Tacmach.New.pf_concl gl))); (* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*) ] - end } + end let micromega_genr prover tac = let parse_arith = parse_rarith in @@ -2080,7 +2078,7 @@ let micromega_genr prover tac = proof_typ = Lazy.force coq_QWitness ; dump_proof = dump_psatz coq_Q dump_q } in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Tacmach.New.pf_concl gl in let hyps = Tacmach.New.pf_hyps_types gl in @@ -2144,7 +2142,7 @@ let micromega_genr prover tac = ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end } + end diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 0cd18ae50..465e77019 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -28,7 +28,6 @@ open Globnames open Nametab open Contradiction open Misctypes -open Proofview.Notations open Context.Named.Declaration module NamedDecl = Context.Named.Declaration @@ -38,12 +37,12 @@ open OmegaSolver (* Added by JCF, 09/03/98 *) let elim_id id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> simplest_elim (mkVar id) - end } -let resolve_id id = Proofview.Goal.enter { enter = begin fun gl -> + end +let resolve_id id = Proofview.Goal.enter begin fun gl -> apply (mkVar id) -end } +end let timing timer_name f arg = f arg @@ -580,10 +579,10 @@ let abstract_path sigma typ path t = let focused_simpl path = let open Tacmach.New in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let newc = context (project gl) (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in convert_concl_no_check newc DEFAULTcast - end } + end let focused_simpl path = focused_simpl path @@ -643,17 +642,16 @@ let decompile af = (** Backward compat to emulate the old Refine: normalize the goal conclusion *) let new_hole env sigma c = - let c = Reductionops.nf_betaiota (Sigma.to_evar_map sigma) c in + let c = Reductionops.nf_betaiota sigma c in Evarutil.new_evar env sigma c let clever_rewrite_base_poly typ p result theorem = let open Tacmach.New in - let open Sigma in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let full = pf_concl gl in let env = pf_env gl in let (abstracted,occ) = abstract_path (project gl) typ (List.rev p) full in - Refine.refine { run = begin fun sigma -> + Refine.refine begin fun sigma -> let t = applist (mkLambda @@ -667,10 +665,10 @@ let clever_rewrite_base_poly typ p result theorem = [abstracted]) in let argt = mkApp (abstracted, [|result|]) in - let Sigma (hole, sigma, p) = new_hole env sigma argt in - Sigma (applist (t, [hole]), sigma, p) - end } - end } + let (sigma, hole) = new_hole env sigma argt in + (sigma, applist (t, [hole])) + end + end let clever_rewrite_base p result theorem = clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem @@ -689,26 +687,25 @@ let clever_rewrite_gen_nat p result (t,args) = (** Solve using the term the term [t _] *) let refine_app gl t = let open Tacmach.New in - let open Sigma in - Refine.refine { run = begin fun sigma -> + Refine.refine begin fun sigma -> let env = pf_env gl in - let ht = match EConstr.kind (Sigma.to_evar_map sigma) (pf_get_type_of gl t) with + let ht = match EConstr.kind sigma (pf_get_type_of gl t) with | Prod (_, t, _) -> t | _ -> assert false in - let Sigma (hole, sigma, p) = new_hole env sigma ht in - Sigma (applist (t, [hole]), sigma, p) - end } + let (sigma, hole) = new_hole env sigma ht in + (sigma, applist (t, [hole])) + end let clever_rewrite p vpath t = let open Tacmach.New in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let full = pf_concl gl in let (abstracted,occ) = abstract_path (project gl) (Lazy.force coq_Z) (List.rev p) full in let vargs = List.map (fun p -> occurrence (project gl) p occ) vpath in let t' = applist(t, (vargs @ [abstracted])) in refine_app gl t' - end } + end let rec shuffle p (t1,t2) = match t1,t2 with @@ -1466,7 +1463,7 @@ let reintroduce id = open Proofview.Notations let coq_omega = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> clear_constr_tables (); let hyps_types = Tacmach.New.pf_hyps_types gl in let destructure_omega = destructure_omega gl in @@ -1514,12 +1511,12 @@ let coq_omega = tclTHEN prelude (replay_history tactic_normalisation path) with NO_CONTRADICTION -> tclZEROMSG (Pp.str"Omega can't solve this system") end - end } + end let coq_omega = coq_omega let nat_inject = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let is_conv = Tacmach.New.pf_apply Reductionops.is_conv gl in let rec explore p t : unit Proofview.tactic = Proofview.tclEVARMAP >>= fun sigma -> @@ -1655,7 +1652,7 @@ let nat_inject = in let hyps_types = Tacmach.New.pf_hyps_types gl in loop (List.rev hyps_types) - end } + end let dec_binop = function | Zne -> coq_dec_Zne @@ -1729,19 +1726,19 @@ let onClearedName id tac = (* so renaming may be necessary *) tclTHEN (tclTRY (clear [id])) - (Proofview.Goal.nf_enter { enter = begin fun gl -> + (Proofview.Goal.nf_enter begin fun gl -> let id = fresh_id [] id gl in tclTHEN (introduction id) (tac id) - end }) + end) let onClearedName2 id tac = tclTHEN (tclTRY (clear [id])) - (Proofview.Goal.nf_enter { enter = begin fun gl -> + (Proofview.Goal.nf_enter begin fun gl -> let id1 = fresh_id [] (add_suffix id "_left") gl in let id2 = fresh_id [] (add_suffix id "_right") gl in tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] - end }) + end) let rec is_Prop sigma c = match EConstr.kind sigma c with | Sort s -> Sorts.is_prop (ESorts.kind sigma s) @@ -1749,7 +1746,7 @@ let rec is_Prop sigma c = match EConstr.kind sigma c with | _ -> false let destructure_hyps = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in let decidability = decidability gl in let pf_nf = pf_nf gl in @@ -1888,10 +1885,10 @@ let destructure_hyps = in let hyps = Proofview.Goal.hyps gl in loop hyps - end } + end let destructure_goal = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let decidability = decidability gl in let rec loop t = @@ -1910,9 +1907,9 @@ let destructure_goal = try let dec = decidability t in tclTHEN - (Proofview.Goal.nf_enter { enter = begin fun gl -> + (Proofview.Goal.nf_enter begin fun gl -> refine_app gl (mkApp (Lazy.force coq_dec_not_not, [| t; dec |])) - end }) + end) intro with Undecidable -> Tactics.elim_type (Lazy.force coq_False) | e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e @@ -1920,7 +1917,7 @@ let destructure_goal = tclTHEN goal_tac destructure_hyps in (loop concl) - end } + end let destructure_goal = destructure_goal diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 59ed8439b..ffacd8b36 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -465,12 +465,12 @@ let pf_constrs_of_globals l = in aux l [] let quote f lid = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let fg = Tacmach.New.pf_global f gl in let clg = List.map (fun id -> Tacmach.New.pf_global id gl) lid in Tacticals.New.pf_constr_of_global fg >>= fun f -> pf_constrs_of_globals clg >>= fun cl -> - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ivs = compute_ivs f (List.map (EConstr.to_constr sigma) cl) gl in @@ -483,16 +483,16 @@ let quote f lid = match ivs.variable_lhs with | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast - end } - end } + end + end let gen_quote cont c f lid = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let fg = Tacmach.New.pf_global f gl in let clg = List.map (fun id -> Tacmach.New.pf_global id gl) lid in Tacticals.New.pf_constr_of_global fg >>= fun f -> pf_constrs_of_globals clg >>= fun cl -> - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let cl = List.map (EConstr.to_constr sigma) cl in @@ -505,8 +505,8 @@ let gen_quote cont c f lid = match ivs.variable_lhs with | None -> cont (mkApp (f, [| p |])) | Some _ -> cont (mkApp (f, [| vm; p |])) - end } - end } + end + end (*i diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index fbed1df17..d97dea039 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -226,7 +226,7 @@ module type Int = sig val mk : Bigint.bigint -> Term.constr val parse_term : Term.constr -> parse_term - val parse_rel : ([ `NF ], 'r) Proofview.Goal.t -> Term.constr -> parse_rel + val parse_rel : [ `NF ] Proofview.Goal.t -> Term.constr -> parse_rel (* check whether t is built only with numbers and + * - *) val get_scalar : Term.constr -> Bigint.bigint option end diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index ca23ed6c4..a452b1a91 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -113,7 +113,7 @@ module type Int = (* parsing a term (one level, except if a number is found) *) val parse_term : Term.constr -> parse_term (* parsing a relation expression, including = < <= >= > *) - val parse_rel : ([ `NF ], 'r) Proofview.Goal.t -> Term.constr -> parse_rel + val parse_rel : [ `NF ] Proofview.Goal.t -> Term.constr -> parse_rel (* Is a particular term only made of numbers and + * - ? *) val get_scalar : Term.constr -> Bigint.bigint option end diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index fdcd62299..575634174 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -8,7 +8,6 @@ open Pp open Util -open Proofview.Notations open Const_omega module OmegaSolver = Omega_plugin.Omega.MakeOmegaSolver (Bigint) open OmegaSolver @@ -1029,7 +1028,7 @@ let resolution unsafe env (reified_concl,reified_hyps) systems_list = Tactics.apply (EConstr.of_constr (Lazy.force coq_I)) let total_reflexive_omega_tactic unsafe = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> Coqlib.check_required_library ["Coq";"romega";"ROmega"]; rst_omega_eq (); rst_omega_var (); @@ -1043,4 +1042,5 @@ let total_reflexive_omega_tactic unsafe = if !debug then display_systems systems_list; resolution unsafe env reified_goal systems_list with NO_CONTRADICTION -> CErrors.user_err Pp.(str "ROmega can't solve this system") - end } + end + diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index cca5cde15..85cbdc5a4 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -749,7 +749,7 @@ let ltac_ring_structure e = lemma1;lemma2;pretac;posttac] let ring_lookup (f : Value.t) lH rl t = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try (* find_ring_strucure can raise an exception *) @@ -761,7 +761,7 @@ let ring_lookup (f : Value.t) lH rl t = let ring = ltac_ring_structure e in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl])) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e - end } + end (***********************************************************************) @@ -1035,7 +1035,7 @@ let ltac_field_structure e = field_simpl_eq_in_ok;cond_ok;pretac;posttac] let field_lookup (f : Value.t) lH rl t = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try @@ -1047,4 +1047,4 @@ let field_lookup (f : Value.t) lH rl t = let field = ltac_field_structure e in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl])) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e - end } + end diff --git a/pretyping/cases.ml b/pretyping/cases.ml index efab5b977..c3f392980 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -32,7 +32,6 @@ open Evardefine open Evarsolve open Evarconv open Evd -open Sigma.Notations open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration @@ -2000,10 +1999,8 @@ let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = let sigma,t = match tycon with | Some t -> refresh_tycon sigma t | None -> - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma ((t, _), sigma, _) = + let (sigma, (t, _)) = new_type_evar env sigma univ_flexible_alg ~src:(Loc.tag ?loc @@ Evar_kinds.CasesType false) in - let sigma = Sigma.to_evar_map sigma in sigma, t in (* First strategy: we build an "inversion" predicate *) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 1d6b611da..3757ba7e6 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -23,7 +23,6 @@ open Evardefine open Evarsolve open Evd open Pretype_errors -open Sigma.Notations open Context.Named.Declaration module RelDecl = Context.Rel.Declaration @@ -913,9 +912,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) (i,t2::ks, m-1, test) else let dloc = Loc.tag Evar_kinds.InternalHole in - let i = Sigma.Unsafe.of_evar_map i in - let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (substl ks b) in - let i' = Sigma.to_evar_map i' in + let (i', ev) = Evarutil.new_evar env i ~src:dloc (substl ks b) in (i', ev :: ks, m - 1,test)) (evd,[],List.length bs,fun i -> Success i) bs in @@ -1099,9 +1096,8 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = | None -> let evty = set_holes evdref cty subst in let instance = Filter.filter_list filter instance in - let evd = Sigma.Unsafe.of_evar_map !evdref in - let Sigma (ev, evd, _) = new_evar_instance sign evd evty ~filter instance in - let evd = Sigma.to_evar_map evd in + let evd = !evdref in + let (evd, ev) = new_evar_instance sign evd evty ~filter instance in evdref := evd; evsref := (fst (destEvar !evdref ev),evty)::!evsref; ev in diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index a11619846..2d86daadb 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -17,15 +17,9 @@ open Namegen open Evd open Evarutil open Pretype_errors -open Sigma.Notations module RelDecl = Context.Rel.Declaration -let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ = - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in - (Sigma.to_evar_map evd, evk) - let env_nf_evar sigma env = let nf_evar c = nf_evar sigma c in process_rel_context @@ -82,9 +76,7 @@ let define_pure_evar_as_product evd evk = let concl = Reductionops.whd_all evenv evd (EConstr.of_constr evi.evar_concl) in let s = destSort evd concl in let evd1,(dom,u1) = - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (e, evd1, _) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in - (Sigma.to_evar_map evd1, e) + new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in let evd2,rng = let newenv = push_named (LocalAssum (id, dom)) evenv in @@ -92,13 +84,11 @@ let define_pure_evar_as_product evd evk = let filter = Filter.extend 1 (evar_filter evi) in if is_prop_sort (ESorts.kind evd1 s) then (* Impredicative product, conclusion must fall in [Prop]. *) - new_evar_unsafe newenv evd1 concl ~src ~filter + new_evar newenv evd1 concl ~src ~filter else let status = univ_flexible_alg in let evd3, (rng, srng) = - let evd1 = Sigma.Unsafe.of_evar_map evd1 in - let Sigma (e, evd3, _) = new_type_evar newenv evd1 status ~src ~filter in - (Sigma.to_evar_map evd3, e) + new_type_evar newenv evd1 status ~src ~filter in let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) (ESorts.kind evd1 s) in @@ -143,7 +133,7 @@ let define_pure_evar_as_lambda env evd evk = let newenv = push_named (LocalAssum (id, dom)) evenv in let filter = Filter.extend 1 (evar_filter evi) in let src = evar_source evk evd1 in - let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in + let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in let lam = mkLambda (Name id, dom, subst_var id body) in Evd.define evk (EConstr.Unsafe.to_constr lam) evd2, lam diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index de5a62726..ff0aeff75 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -20,7 +20,6 @@ open Retyping open Reductionops open Evarutil open Pretype_errors -open Sigma.Notations let normalize_evar evd ev = match EConstr.kind evd (mkEvar ev) with @@ -203,9 +202,7 @@ let restrict_evar_key evd evk filter candidates = let candidates = match candidates with | NoUpdate -> Option.map (fun l -> List.map EConstr.of_constr l) evi.evar_candidates | UpdateWith c -> Some c in - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (evk, sigma, _) = restrict_evar sigma evk filter candidates in - (Sigma.to_evar_map sigma, evk) + restrict_evar evd evk filter candidates end (* Restrict an applied evar and returns its restriction in the same context *) @@ -649,9 +646,7 @@ let make_projectable_subst aliases sigma evi args = *) let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env = - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in - let evd = Sigma.to_evar_map evd in + let (evd, evar_in_env) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in let t_in_env = whd_evar evd t_in_env in let (evk, _) = destEvar evd evar_in_env in let evd = define_fun env evd None (destEvar evd evar_in_env) t_in_env in @@ -721,10 +716,8 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src ty_in_env ty_t_in_sign sign2 filter2 inst2_in_env in - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (ev2_in_sign, evd, _) = + let (evd, ev2_in_sign) = new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in - let evd = Sigma.to_evar_map evd in let ev2_in_env = (fst (destEvar evd ev2_in_sign), Array.of_list inst2_in_env) in (evd, ev2_in_sign, ev2_in_env) diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 8a902f3a3..97aec1814 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -27,7 +27,6 @@ open Inductiveops open Environ open Reductionops open Nametab -open Sigma.Notations open Context.Rel.Declaration type dep_flag = bool @@ -130,19 +129,19 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = it_mkLambda_or_LetIn_name env' obj deparsign else let cs = lift_constructor (k+1) constrs.(k) in - let t = build_branch_type env (Sigma.to_evar_map sigma) dep (mkRel (k+1)) cs in + let t = build_branch_type env sigma dep (mkRel (k+1)) cs in mkLambda_string "f" t (add_branch (push_rel (LocalAssum (Anonymous, t)) env) (k+1)) in - let Sigma (s, sigma, p) = Sigma.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in - let typP = make_arity env' (Sigma.to_evar_map sigma) dep indf s in + let (sigma, s) = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in + let typP = make_arity env' sigma dep indf s in let typP = EConstr.Unsafe.to_constr typP in let c = it_mkLambda_or_LetIn_name env (mkLambda_string "P" typP (add_branch (push_rel (LocalAssum (Anonymous,typP)) env') 0)) lnamespar in - Sigma (c, sigma, p) + (sigma, c) (* check if the type depends recursively on one of the inductive scheme *) @@ -475,10 +474,9 @@ let mis_make_indrec env sigma listdepkind mib u = it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) lnamesparrec else - let sigma = Sigma.Unsafe.of_evar_map !evdref in - let Sigma (c, sigma, _) = mis_make_case_com dep env sigma (indi,u) (mibi,mipi) kind in - let evd' = Sigma.to_evar_map sigma in - evdref := evd'; c + let evd = !evdref in + let (evd, c) = mis_make_case_com dep env evd (indi,u) (mibi,mipi) kind in + evdref := evd; c in (* Body of mis_make_indrec *) !evdref, List.init nrec make_one_rec diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli index 192b64a5e..a22470ae8 100644 --- a/pretyping/indrec.mli +++ b/pretyping/indrec.mli @@ -26,14 +26,14 @@ type dep_flag = bool (** Build a case analysis elimination scheme in some sort family *) -val build_case_analysis_scheme : env -> 'r Sigma.t -> pinductive -> - dep_flag -> sorts_family -> (constr, 'r) Sigma.sigma +val build_case_analysis_scheme : env -> Evd.evar_map -> pinductive -> + dep_flag -> sorts_family -> evar_map * Constr.t (** Build a dependent case elimination predicate unless type is in Prop or is a recursive record with primitive projections. *) -val build_case_analysis_scheme_default : env -> 'r Sigma.t -> pinductive -> - sorts_family -> (constr, 'r) Sigma.sigma +val build_case_analysis_scheme_default : env -> evar_map -> pinductive -> + sorts_family -> evar_map * Constr.t (** Builds a recursive induction scheme (Peano-induction style) in the same sort family as the inductive family; it is dependent if not in Prop diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 08a6dd4db..92e728683 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -44,8 +44,6 @@ open Glob_ops open Evarconv open Pattern open Misctypes -open Tactypes -open Sigma.Notations module NamedDecl = Context.Named.Declaration @@ -111,9 +109,9 @@ let e_new_evar env evdref ?src ?naming typ = let typ' = subst2 subst vsubst typ in let instance = inst_rels @ inst_vars in let sign = val_of_named_context nc in - let sigma = Sigma.Unsafe.of_evar_map !evdref in - let Sigma (e, sigma, _) = new_evar_instance sign sigma typ' ?src ?naming instance in - evdref := Sigma.to_evar_map sigma; + let sigma = !evdref in + let (sigma, e) = new_evar_instance sign sigma typ' ?src ?naming instance in + evdref := sigma; e let push_rec_types sigma (lna,typarray,_) env = @@ -390,9 +388,8 @@ let adjust_evar_source evdref na c = begin match evi.evar_source with | loc, Evar_kinds.QuestionMark (b,Anonymous) -> let src = (loc,Evar_kinds.QuestionMark (b,na)) in - let sigma = Sigma.Unsafe.of_evar_map !evdref in - let Sigma (evk', evd, _) = restrict_evar sigma evk (evar_filter evi) ~src None in - evdref := Sigma.to_evar_map evd; + let (evd, evk') = restrict_evar !evdref evk (evar_filter evi) ~src None in + evdref := evd; mkEvar (evk',args) | _ -> c end @@ -571,12 +568,12 @@ let pretype_sort ?loc evdref = function | GType s -> evd_comb1 (judge_of_Type ?loc) evdref s let new_type_evar env evdref loc = - let sigma = Sigma.Unsafe.of_evar_map !evdref in - let Sigma ((e, _), sigma, _) = + let sigma = !evdref in + let (sigma, (e, _)) = Evarutil.new_type_evar env.ExtraEnv.env sigma univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole) in - evdref := Sigma.to_evar_map sigma; + evdref := sigma; e module ConstrInterpObj = @@ -1267,7 +1264,7 @@ let constr_flags = { (* Fully evaluate an untyped constr *) let type_uconstr ?(flags = constr_flags) ?(expected_type = WithoutTypeConstraint) ist c = - { delayed = begin fun env sigma -> + begin fun env sigma -> let { closure; term } = c in let vars = { ltac_constrs = closure.typed; @@ -1275,10 +1272,8 @@ let type_uconstr ?(flags = constr_flags) ltac_idents = closure.idents; ltac_genargs = Id.Map.empty; } in - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = understand_ltac flags env sigma vars expected_type term in - Sigma.Unsafe.of_pair (c, sigma) - end } + understand_ltac flags env sigma vars expected_type term + end let pretype k0 resolve_tc typcon env evdref lvar t = pretype k0 resolve_tc typcon (make_env env !evdref) evdref lvar t diff --git a/pretyping/program.ml b/pretyping/program.ml index 2fa3facb3..f9be82024 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -41,13 +41,8 @@ let coq_JMeq_refl = init_reference ["Logic";"JMeq"] "JMeq_refl" let coq_not = init_reference ["Init";"Logic"] "not" let coq_and = init_reference ["Init";"Logic"] "and" -let new_global sigma gr = - let open Sigma in - let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map sigma) gr - in Sigma.to_evar_map sigma, c - let mk_coq_not sigma x = - let sigma, notc = new_global sigma (coq_not ()) in + let sigma, notc = Evarutil.new_global sigma (coq_not ()) in sigma, EConstr.mkApp (notc, [| x |]) let unsafe_fold_right f = function @@ -55,7 +50,7 @@ let unsafe_fold_right f = function | [] -> invalid_arg "unsafe_fold_right" let mk_coq_and sigma l = - let sigma, and_typ = new_global sigma (coq_and ()) in + let sigma, and_typ = Evarutil.new_global sigma (coq_and ()) in sigma, unsafe_fold_right (fun c conj -> EConstr.mkApp (and_typ, [| c ; conj |])) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index c976fe66d..b4654bfb5 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -595,7 +595,7 @@ type state = constr * constr Stack.t type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr -type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma } +type e_reduction_function = env -> evar_map -> constr -> evar_map * constr type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index af8048156..af0e28cdd 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -117,7 +117,7 @@ type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr -type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma } +type e_reduction_function = env -> evar_map -> constr -> evar_map * constr type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index f2b0995b0..ec3669bfe 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -24,7 +24,6 @@ open Reductionops open Cbv open Patternops open Locus -open Sigma.Notations module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration @@ -399,9 +398,8 @@ let substl_with_function subst sigma constr = if i <= k + Array.length v then match v.(i-k-1) with | (fx, Some (min, ref)) -> - let sigma = Sigma.Unsafe.of_evar_map !evd in - let Sigma (evk, sigma, _) = Evarutil.new_pure_evar venv sigma dummy in - let sigma = Sigma.to_evar_map sigma in + let sigma = !evd in + let (sigma, evk) = Evarutil.new_pure_evar venv sigma dummy in evd := sigma; minargs := Evar.Map.add evk min !minargs; Vars.lift k (mkEvar (evk, [|fx;ref|])) @@ -983,11 +981,10 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = | _ -> mkApp (app', [| a' |])) | _ -> map_constr_with_binders_left_to_right sigma g f acc c -let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> +let e_contextually byhead (occs,c) f = begin fun env sigma t -> let (nowhere_except_in,locs) = Locusops.convert_occs occs in let maxocc = List.fold_right max locs 0 in let pos = ref 1 in - let sigma = Sigma.to_evar_map sigma in (** FIXME: we do suspicious things with this evarmap *) let evd = ref sigma in let rec traverse nested (env,c as envc) t = @@ -1007,8 +1004,8 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> (* Skip inner occurrences for stable counting of occurrences *) if locs != [] then ignore (traverse_below (Some (!pos-1)) envc t); - let Sigma (t, evm, _) = (f subst).e_redfun env (Sigma.Unsafe.of_evar_map !evd) t in - (evd := Sigma.to_evar_map evm; t) + let (evm, t) = (f subst) env !evd t in + (evd := evm; t) end else traverse_below nested envc t @@ -1027,15 +1024,12 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> in let t' = traverse None (env,c) t in if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs; - Sigma.Unsafe.of_pair (t', !evd) - end } + (!evd, t') + end let contextually byhead occs f env sigma t = - let f' subst = { e_redfun = begin fun env sigma t -> - Sigma.here (f subst env (Sigma.to_evar_map sigma) t) sigma - end } in - let Sigma (c, _, _) = (e_contextually byhead occs f').e_redfun env (Sigma.Unsafe.of_evar_map sigma) t in - c + let f' subst env sigma t = sigma, f subst env sigma t in + snd (e_contextually byhead occs f' env sigma t) (* linear bindings (following pretty-printer) of the value of name in c. * n is the number of the next occurrence of name. @@ -1154,15 +1148,14 @@ let abstract_scheme env sigma (locc,a) (c, sigma) = let c', sigma' = subst_closed_term_occ env sigma (AtOccs locc) a c in mkLambda (na,ta,c'), sigma' -let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c -> - let sigma = Sigma.to_evar_map sigma in +let pattern_occs loccs_trm = begin fun env sigma c -> let abstr_trm, sigma = List.fold_right (abstract_scheme env sigma) loccs_trm (c,sigma) in try let _ = Typing.unsafe_type_of env sigma abstr_trm in - Sigma.Unsafe.of_pair (applist(abstr_trm, List.map snd loccs_trm), sigma) + (sigma, applist(abstr_trm, List.map snd loccs_trm)) with Type_errors.TypeError (env',t) -> raise (ReductionTacticError (InvalidAbstraction (env,sigma,abstr_trm,(env',t)))) - end } + end (* Used in several tactics. *) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index d1643a8c7..0fb48ed8c 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -31,7 +31,6 @@ open Recordops open Locus open Locusops open Find_subterm -open Sigma.Notations type metabinding = (metavariable * EConstr.constr * (instance_constraint * instance_typing_status)) @@ -145,9 +144,7 @@ let set_occurrences_of_last_arg args = Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args) let abstract_list_all_with_dependencies env evd typ c l = - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (ev, evd, _) = new_evar env evd typ in - let evd = Sigma.to_evar_map evd in + let (evd, ev) = new_evar env evd typ in let evd,ev' = evar_absorb_arguments env evd (destEvar evd ev) l in let n = List.length l in let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in @@ -1239,20 +1236,19 @@ let merge_instances env sigma flags st1 st2 c1 c2 = * close it off. But this might not always work, * since other metavars might also need to be resolved. *) -let applyHead env (type r) (evd : r Sigma.t) n c = - let rec apprec : type s. _ -> _ -> _ -> (r, s) Sigma.le -> s Sigma.t -> (constr, r) Sigma.sigma = - fun n c cty p evd -> +let applyHead env evd n c = + let rec apprec n c cty evd = if Int.equal n 0 then - Sigma (c, evd, p) + (evd, c) else - let sigma = Sigma.to_evar_map evd in - match EConstr.kind sigma (whd_all env sigma cty) with + match EConstr.kind evd (whd_all env evd cty) with | Prod (_,c1,c2) -> - let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.tag Evar_kinds.GoalEvar) c1 in - apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd' + let (evd',evar) = + Evarutil.new_evar env evd ~src:(Loc.tag Evar_kinds.GoalEvar) c1 in + apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd' | _ -> user_err Pp.(str "Apply_Head_Then") in - apprec n c (Typing.unsafe_type_of env (Sigma.to_evar_map evd) c) Sigma.refl evd + apprec n c (Typing.unsafe_type_of env evd c) evd let is_mimick_head sigma ts f = match EConstr.kind sigma f with @@ -1416,9 +1412,7 @@ let w_merge env with_types flags (evd,metas,evars : subst0) = and mimick_undefined_evar evd flags hdc nargs sp = let ev = Evd.find_undefined evd sp in let sp_env = Global.env_of_context ev.evar_hyps in - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (c, evd', _) = applyHead sp_env evd nargs hdc in - let evd' = Sigma.to_evar_map evd' in + let (evd', c) = applyHead sp_env evd nargs hdc in let (evd'',mc,ec) = unify_0 sp_env evd' CUMUL flags (get_type_of sp_env evd' c) (EConstr.of_constr ev.evar_concl) in @@ -1534,10 +1528,9 @@ let indirectly_dependent sigma c d decls = List.exists (fun d' -> dependent_in_decl sigma (EConstr.mkVar (NamedDecl.get_id d')) d) decls let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) = - let current_sigma = Sigma.to_evar_map current_sigma in let sigma = Pretyping.solve_remaining_evars flags env current_sigma pending in let sigma, subst = nf_univ_variables sigma in - Sigma.Unsafe.of_pair (EConstr.of_constr (CVars.subst_univs_constr subst (EConstr.Unsafe.to_constr (nf_evar sigma c))), sigma) + (sigma, EConstr.of_constr (CVars.subst_univs_constr subst (EConstr.Unsafe.to_constr (nf_evar sigma c)))) let default_matching_core_flags sigma = let ts = Names.full_transparent_state in { @@ -1684,7 +1677,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = if List.is_empty depdecls then None else Some (NamedDecl.get_id (List.last depdecls)) in let res = match out test with | None -> None - | Some (sigma, c) -> Some (Sigma.Unsafe.of_pair (c, sigma)) + | Some (sigma, c) -> Some (sigma,c) in (id,sign,depdecls,lastlhyp,ccl,res) with @@ -1711,10 +1704,9 @@ type abstraction_request = type 'r abstraction_result = Names.Id.t * named_context_val * named_declaration list * Names.Id.t option * - types * (constr, 'r) Sigma.sigma option + types * (evar_map * constr) option let make_abstraction env evd ccl abs = - let evd = Sigma.to_evar_map evd in match abs with | AbstractPattern (from_prefix,check,name,c,occs,check_occs) -> make_abstraction_core name diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 8d7e3521d..0d90ab158 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -76,14 +76,14 @@ type abstraction_request = | AbstractExact of Names.Name.t * constr * types option * Locus.clause * bool val finish_evar_resolution : ?flags:Pretyping.inference_flags -> - env -> 'r Sigma.t -> (evar_map * constr) -> (constr, 'r) Sigma.sigma + env -> evar_map -> (evar_map * constr) -> evar_map * constr type 'r abstraction_result = Names.Id.t * named_context_val * named_declaration list * Names.Id.t option * - types * (constr, 'r) Sigma.sigma option + types * (evar_map * constr) option -val make_abstraction : env -> 'r Sigma.t -> constr -> +val make_abstraction : env -> evar_map -> constr -> abstraction_request -> 'r abstraction_result val pose_all_metas_as_evars : env -> evar_map -> constr -> evar_map * constr diff --git a/proofs/clenv.ml b/proofs/clenv.ml index d6ed201d8..79d2e4694 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -25,7 +25,6 @@ open Pretype_errors open Evarutil open Unification open Misctypes -open Sigma.Notations (******************************************************************) (* Clausal environments *) @@ -337,9 +336,8 @@ let clenv_pose_metas_as_evars clenv dep_mvs = else let src = evar_source_of_meta mv clenv.evd in let src = adjust_meta_source clenv.evd mv src in - let evd = Sigma.Unsafe.of_evar_map clenv.evd in - let Sigma (evar, evd, _) = new_evar (cl_env clenv) evd ~src ty in - let evd = Sigma.to_evar_map evd in + let evd = clenv.evd in + let (evd, evar) = new_evar (cl_env clenv) evd ~src ty in let clenv = clenv_assign mv evar {clenv with evd=evd} in fold clenv mvs in fold clenv dep_mvs @@ -614,9 +612,7 @@ let make_evar_clause env sigma ?len t = | Cast (t, _, _) -> clrec (sigma, holes) n t | Prod (na, t1, t2) -> let store = Typeclasses.set_resolvable Evd.Store.empty false in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (ev, sigma, _) = new_evar ~store env sigma t1 in - let sigma = Sigma.to_evar_map sigma in + let (sigma, ev) = new_evar ~store env sigma t1 in let dep = not (noccurn sigma 1 t2) in let hole = { hole_evar = ev; diff --git a/proofs/clenv.mli b/proofs/clenv.mli index 4bcd50591..f43c0531d 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, 'r) Proofview.Goal.t -> EConstr.constr * EConstr.types -> clausenv +val mk_clenv_from : 'a Proofview.Goal.t -> EConstr.constr * EConstr.types -> clausenv val mk_clenv_from_n : - ('a, 'r) Proofview.Goal.t -> int option -> EConstr.constr * EConstr.types -> clausenv -val mk_clenv_type_of : ('a, 'r) Proofview.Goal.t -> EConstr.constr -> clausenv + 'a Proofview.Goal.t -> int option -> EConstr.constr * EConstr.types -> clausenv +val mk_clenv_type_of : 'a 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, 'r) Proofview.Goal.t -> clausenv + ?flags:unify_flags -> clausenv -> 'a Proofview.Goal.t -> clausenv val clenv_dependent : clausenv -> metavariable list diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 0722ea047..2ce144a6d 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -17,7 +17,6 @@ open Logic open Reduction open Tacmach open Clenv -open Proofview.Notations (* This function put casts around metavariables whose type could not be * infered by the refiner, that is head of applications, predicates and @@ -104,10 +103,10 @@ open Unification let dft = default_unify_flags let res_pf ?(with_evars=false) ?(with_classes=true) ?(flags=dft ()) clenv = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let clenv = clenv_unique_resolver ~flags clenv gl in clenv_refine with_evars ~with_classes clenv - end } + end (* [unifyTerms] et [unify] ne semble pas gérer les Meta, en particulier ne semblent pas vérifier que des instances différentes @@ -139,7 +138,7 @@ let fail_quick_unif_flags = { (* let unifyTerms m n = walking (fun wc -> fst (w_Unify CONV m n [] wc)) *) let unify ?(flags=fail_quick_unif_flags) m = - Proofview.Goal.enter { enter = begin fun gl -> + 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 evd = clear_metas (Tacmach.New.project gl) in @@ -147,4 +146,4 @@ let unify ?(flags=fail_quick_unif_flags) m = let evd' = w_unify env evd CONV ~flags m n in Proofview.Unsafe.tclEVARSADVANCE evd' with e when CErrors.noncritical e -> Proofview.tclZERO e - end } + end diff --git a/proofs/goal.ml b/proofs/goal.ml index 5a717f166..e69ef18fd 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -8,7 +8,6 @@ open Util open Pp -open Sigma.Notations module NamedDecl = Context.Named.Declaration @@ -73,9 +72,7 @@ module V82 = struct Evd.evar_extra = extra } in let evi = Typeclasses.mark_unresolvable evi in - let evars = Sigma.Unsafe.of_evar_map evars in - let Sigma (evk, evars, _) = Evarutil.new_pure_evar_full evars evi in - let evars = Sigma.to_evar_map evars in + let (evars, evk) = Evarutil.new_pure_evar_full evars evi 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 (NamedDecl.get_id %> EConstr.mkVar) ctxt in @@ -131,9 +128,7 @@ module V82 = struct let new_evi = { evi with Evd.evar_hyps = new_hyps; Evd.evar_filter = new_filter } in let new_evi = Typeclasses.mark_unresolvable new_evi in - let sigma = Sigma.Unsafe.of_evar_map Evd.empty in - let Sigma (evk, sigma, _) = Evarutil.new_pure_evar_full sigma new_evi in - let sigma = Sigma.to_evar_map sigma in + let (sigma, evk) = Evarutil.new_pure_evar_full Evd.empty new_evi in { Evd.it = evk ; sigma = sigma; } (* Used by the compatibility layer and typeclasses *) diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 383a6a523..458dd2161 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -201,7 +201,7 @@ let out_arg = function let out_with_occurrences (occs,c) = (Locusops.occurrences_map (List.map out_arg) occs, c) -let e_red f = { e_redfun = fun env evm c -> Sigma.here (f env (Sigma.to_evar_map evm) c) evm } +let e_red f env evm c = evm, f env evm c let head_style = false (* Turn to true to have a semantics where simpl only reduce at the head when an evaluable reference is given, e.g. diff --git a/proofs/refine.ml b/proofs/refine.ml index 63ae41075..caa6b9fb3 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -7,7 +7,6 @@ (************************************************************************) open Util -open Sigma.Notations open Proofview.Notations open Context.Named.Declaration @@ -73,7 +72,6 @@ let add_side_effects env effects = let generic_refine ?(unsafe = true) f gl = let gl = Proofview.Goal.assume gl in let sigma = Proofview.Goal.sigma gl in - let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in (** Save the [future_goals] state to restore them after the @@ -129,19 +127,20 @@ let generic_refine ?(unsafe = true) f gl = let lift c = Proofview.tclEVARMAP >>= fun sigma -> Proofview.V82.wrap_exceptions begin fun () -> - let Sigma (c, sigma, _) = c.run (Sigma.Unsafe.of_evar_map sigma) in - Proofview.Unsafe.tclEVARS (Sigma.to_evar_map sigma) >>= fun () -> + let (sigma, c) = c sigma in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> Proofview.tclUNIT c end -let make_refine_enter ?unsafe f = - { enter = fun gl -> generic_refine ?unsafe (lift f) gl } +let make_refine_enter ?unsafe f gl = generic_refine ?unsafe (lift f) gl 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 + let f evd = + let (evd,c) = f evd in (evd,((), c)) + in Proofview.Goal.enter (make_refine_enter ~unsafe f) (** Useful definitions *) @@ -154,17 +153,16 @@ let with_type env evd c t = in evd , j'.Environ.uj_val -let refine_casted ?unsafe f = Proofview.Goal.enter { enter = begin fun gl -> +let refine_casted ?unsafe 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 = { run = fun h -> - let Sigma (c, h, p) = f.run h in - let sigma, c = with_type env (Sigma.to_evar_map h) c concl in - Sigma (c, Sigma.Unsafe.of_evar_map sigma, p) - } in + let f h = + let (h, c) = f h in + with_type env h c concl + in refine ?unsafe f -end } +end (** {7 solve_constraints} diff --git a/proofs/refine.mli b/proofs/refine.mli index 5098f246a..f1439f9a1 100644 --- a/proofs/refine.mli +++ b/proofs/refine.mli @@ -21,7 +21,7 @@ val pr_constr : (** {7 Refinement primitives} *) -val refine : ?unsafe:bool -> EConstr.t Sigma.run -> unit tactic +val refine : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit tactic (** In [refine ?unsafe t], [t] is a term with holes under some [evar_map] context. The term [t] is used as a partial solution for the current goal (refine is a goal-dependent tactic), the @@ -30,11 +30,11 @@ val refine : ?unsafe:bool -> EConstr.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 * EConstr.t) Sigma.run -> 'a tactic +val refine_one : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * ('a * EConstr.t)) -> 'a tactic (** A variant of [refine] which assumes exactly one goal under focus *) val generic_refine : ?unsafe:bool -> ('a * EConstr.t) tactic -> - ([ `NF ], 'r) Proofview.Goal.t -> 'a tactic + [ `NF ] Proofview.Goal.t -> 'a tactic (** The general version of refine. *) (** {7 Helper functions} *) @@ -44,7 +44,7 @@ val with_type : Environ.env -> Evd.evar_map -> (** [with_type env sigma c t] ensures that [c] is of type [t] inserting a coercion if needed. *) -val refine_casted : ?unsafe:bool -> EConstr.t Sigma.run -> unit tactic +val refine_casted : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit tactic (** Like {!refine} except the refined term is coerced to the conclusion of the current goal. *) diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 66d91c634..f9d9f25cc 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -18,7 +18,6 @@ open Tacred open Proof_type open Logic open Refiner -open Sigma.Notations open Context.Named.Declaration module NamedDecl = Context.Named.Declaration @@ -79,9 +78,8 @@ let pf_global gls id = EConstr.of_constr (Universes.constr_of_global (Constrinte let pf_reduction_of_red_expr gls re c = let (redfun, _) = reduction_of_red_expr (pf_env gls) re in - let sigma = Sigma.Unsafe.of_evar_map (project gls) in - let Sigma (c, sigma, _) = redfun.e_redfun (pf_env gls) sigma c in - (Sigma.to_evar_map sigma, c) + let sigma = project gls in + redfun (pf_env gls) sigma c let pf_apply f gls = f (pf_env gls) (project gls) let pf_eapply f gls x = @@ -158,8 +156,7 @@ let pr_glls glls = module New = struct let project gl = - let sigma = Proofview.Goal.sigma gl in - Sigma.to_evar_map sigma + Proofview.Goal.sigma gl let pf_apply f gl = f (Proofview.Goal.env gl) (project gl) @@ -216,7 +213,7 @@ module New = struct let hyps = Proofview.Goal.hyps gl in List.hd hyps - let pf_nf_concl (gl : ([ `LZ ], 'r) Proofview.Goal.t) = + let pf_nf_concl (gl : [ `LZ ] Proofview.Goal.t) = (** We normalize the conclusion just after *) let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 1172e55ac..3d2fa72c1 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -99,47 +99,47 @@ val pr_glls : goal list sigma -> Pp.std_ppcmds (* Variants of [Tacmach] functions built with the new proof engine *) module New : sig - val pf_apply : (env -> evar_map -> 'a) -> ('b, 'r) Proofview.Goal.t -> 'a - val pf_global : identifier -> ('a, 'r) Proofview.Goal.t -> Globnames.global_reference + val pf_apply : (env -> evar_map -> 'a) -> 'b Proofview.Goal.t -> 'a + val pf_global : identifier -> 'a Proofview.Goal.t -> Globnames.global_reference (** FIXME: encapsulate the level in an existential type. *) - val of_old : (Proof_type.goal Evd.sigma -> 'a) -> ([ `NF ], 'r) Proofview.Goal.t -> 'a + val of_old : (Proof_type.goal Evd.sigma -> 'a) -> [ `NF ] Proofview.Goal.t -> 'a - val project : ('a, 'r) Proofview.Goal.t -> Evd.evar_map - val pf_env : ('a, 'r) Proofview.Goal.t -> Environ.env - val pf_concl : ('a, 'r) Proofview.Goal.t -> types + 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 (** 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 -> constr -> types + val pf_unsafe_type_of : 'a 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, 'r) Proofview.Goal.t -> constr -> types + val pf_get_type_of : 'a 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, 'r) Proofview.Goal.t -> constr -> evar_map * types - val pf_conv_x : ('a, 'r) Proofview.Goal.t -> t -> t -> bool + 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 : identifier -> ('a, 'r) Proofview.Goal.t -> identifier - val pf_ids_of_hyps : ('a, 'r) Proofview.Goal.t -> identifier list - val pf_hyps_types : ('a, 'r) Proofview.Goal.t -> (identifier * types) list + val pf_get_new_id : identifier -> 'a Proofview.Goal.t -> identifier + val pf_ids_of_hyps : 'a Proofview.Goal.t -> identifier list + val pf_hyps_types : 'a Proofview.Goal.t -> (identifier * types) list - val pf_get_hyp : identifier -> ('a, 'r) Proofview.Goal.t -> named_declaration - val pf_get_hyp_typ : identifier -> ('a, 'r) Proofview.Goal.t -> types - val pf_last_hyp : ('a, 'r) Proofview.Goal.t -> named_declaration + val pf_get_hyp : identifier -> 'a Proofview.Goal.t -> named_declaration + val pf_get_hyp_typ : identifier -> 'a Proofview.Goal.t -> types + val pf_last_hyp : 'a Proofview.Goal.t -> named_declaration - val pf_nf_concl : ([ `LZ ], 'r) Proofview.Goal.t -> types - val pf_reduce_to_quantified_ind : ('a, 'r) Proofview.Goal.t -> types -> (inductive * EInstance.t) * types + 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_hnf_constr : ('a, 'r) Proofview.Goal.t -> constr -> types - val pf_hnf_type_of : ('a, 'r) Proofview.Goal.t -> constr -> types + val pf_hnf_constr : 'a Proofview.Goal.t -> constr -> types + val pf_hnf_type_of : 'a Proofview.Goal.t -> constr -> types - val pf_whd_all : ('a, 'r) Proofview.Goal.t -> constr -> constr - val pf_compute : ('a, 'r) Proofview.Goal.t -> constr -> constr + val pf_whd_all : 'a Proofview.Goal.t -> constr -> constr + val pf_compute : 'a Proofview.Goal.t -> constr -> constr - val pf_matches : ('a, 'r) Proofview.Goal.t -> constr_pattern -> constr -> patvar_map + val pf_matches : 'a Proofview.Goal.t -> constr_pattern -> constr -> patvar_map - val pf_nf_evar : ('a, 'r) Proofview.Goal.t -> constr -> constr + val pf_nf_evar : 'a Proofview.Goal.t -> constr -> constr end diff --git a/stm/stm.ml b/stm/stm.ml index 739bc01e6..e95bec099 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1836,7 +1836,7 @@ end = struct (* {{{ *) 1 goals in TaskQueue.join queue; let assign_tac : unit Proofview.tactic = - Proofview.(Goal.nf_enter { Goal.enter = fun g -> + Proofview.(Goal.nf_enter begin fun g -> let gid = Goal.goal g in let f = try List.assoc gid res @@ -1859,7 +1859,7 @@ end = struct (* {{{ *) Tactics.exact_no_check (EConstr.of_constr pt)) with TacTask.NoProgress -> if solve then Tacticals.New.tclSOLVE [] else tclUNIT () - }) + end) in Proof.run_tactic (Global.env()) assign_tac p)))) ()) @@ -2108,12 +2108,11 @@ let known_state ?(redefine_qed=false) ~cache id = | `Leaks -> Exninfo.iraise exn | `ValidBlock { base_state; goals_to_admit; recovery_command } -> begin let tac = - let open Proofview.Notations in - Proofview.Goal.nf_enter { enter = fun gl -> + Proofview.Goal.nf_enter begin fun gl -> if CList.mem_f Evar.equal (Proofview.Goal.goal gl) goals_to_admit then Proofview.give_up else Proofview.tclUNIT () - } in + end in match (VCS.get_info base_state).state with | Valid { proof } -> Proof_global.unfreeze proof; diff --git a/tactics/auto.ml b/tactics/auto.ml index e21396548..272cb1eda 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -97,11 +97,11 @@ let connect_hint_clenv poly (c, _, ctx) clenv gl = in clenv, c let unify_resolve poly flags ((c : raw_hint), clenv) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let clenv, c = connect_hint_clenv poly c clenv gl in let clenv = clenv_unique_resolver ~flags clenv gl in Clenvtac.clenv_refine false clenv - end } + end let unify_resolve_nodelta poly h = unify_resolve poly auto_unif_flags h @@ -110,12 +110,12 @@ let unify_resolve_gen poly = function | Some flags -> unify_resolve poly flags let exact poly (c,clenv) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let clenv', c = connect_hint_clenv poly c clenv gl in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) (exact_check c) - end } + end (* Util *) @@ -141,7 +141,7 @@ let conclPattern concl pat tac = with Constr_matching.PatternMatchingFailure -> Tacticals.New.tclZEROMSG (str "pattern-matching failed") in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in constr_bindings env sigma >>= fun constr_bindings -> @@ -157,7 +157,7 @@ let conclPattern concl pat tac = match tac with | GenArg (Glbwit wit, tac) -> Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) - end } + end (***********************************************************) (** A debugging / verbosity framework for trivial and auto *) @@ -313,7 +313,7 @@ let dbg_assumption dbg = tclLOG dbg (fun () -> str "assumption") assumption let rec trivial_fail_db dbg mod_delta db_list local_db = let intro_tac = Tacticals.New.tclTHEN (dbg_intro dbg) - ( Proofview.Goal.enter { enter = begin fun gl -> + ( Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let nf c = Evarutil.nf_evar sigma c in @@ -322,9 +322,9 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = let hintl = make_resolve_hyp env sigma hyp in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list env sigma hintl local_db) - end }) + end) in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Tacmach.New.pf_concl gl in let sigma = Tacmach.New.project gl in let secvars = compute_secvars gl in @@ -332,7 +332,7 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = ((dbg_assumption dbg)::intro_tac:: (List.map Tacticals.New.tclCOMPLETE (trivial_resolve sigma dbg mod_delta db_list local_db secvars concl))) - end } + end and my_find_search_nodelta sigma db_list local_db secvars hdc concl = List.map (fun hint -> (None,hint)) @@ -375,7 +375,7 @@ and my_find_search_delta sigma db_list local_db secvars hdc concl = and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db=dbname})) = let tactic = function | Res_pf (c,cl) -> unify_resolve_gen poly flags (c,cl) - | ERes_pf _ -> Proofview.Goal.enter { enter = fun gl -> Tacticals.New.tclZEROMSG (str "eres_pf") } + | ERes_pf _ -> Proofview.Goal.enter (fun gl -> Tacticals.New.tclZEROMSG (str "eres_pf")) | Give_exact (c, cl) -> exact poly (c, cl) | Res_pf_THEN_trivial_fail (c,cl) -> Tacticals.New.tclTHEN @@ -384,11 +384,11 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db= with "debug auto" we don't display the details of inner trivial *) (trivial_fail_db (no_dbg ()) (not (Option.is_empty flags)) db_list local_db) | Unfold_nth c -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> if exists_evaluable_reference (Tacmach.New.pf_env gl) c then Tacticals.New.tclPROGRESS (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl) else Tacticals.New.tclFAIL 0 (str"Unbound reference") - end } + end | Extern tacast -> conclPattern concl p tacast in @@ -417,7 +417,7 @@ and trivial_resolve sigma dbg mod_delta db_list local_db secvars cl = "nocore" amongst the databases. *) let trivial ?(debug=Off) lems dbnames = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = make_db_list dbnames in @@ -425,10 +425,10 @@ let trivial ?(debug=Off) lems dbnames = let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (trivial_fail_db d false db_list hints) - end } + end let full_trivial ?(debug=Off) lems = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = current_pure_db () in @@ -436,7 +436,7 @@ let full_trivial ?(debug=Off) lems = let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (trivial_fail_db d false db_list hints) - end } + end let gen_trivial ?(debug=Off) lems = function | None -> full_trivial ~debug lems @@ -469,10 +469,10 @@ let extend_local_db decl db gl = let intro_register dbg kont db = Tacticals.New.tclTHEN (dbg_intro dbg) - (Proofview.Goal.enter { enter = begin fun gl -> + (Proofview.Goal.enter begin fun gl -> let extend_local_db decl db = extend_local_db decl db gl in Tacticals.New.onLastDecl (fun decl -> kont (extend_local_db decl db)) - end }) + end) (* n is the max depth of search *) (* local_db contains the local Hypotheses *) @@ -485,7 +485,7 @@ let search d n mod_delta db_list local_db = if Int.equal n 0 then Tacticals.New.tclZEROMSG (str"BOUND 2") else Tacticals.New.tclORELSE0 (dbg_assumption d) (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) - ( Proofview.Goal.enter { enter = begin fun gl -> + ( Proofview.Goal.enter begin fun gl -> let concl = Tacmach.New.pf_concl gl in let sigma = Tacmach.New.project gl in let secvars = compute_secvars gl in @@ -494,7 +494,7 @@ let search d n mod_delta db_list local_db = (List.map (fun ntac -> Tacticals.New.tclTHEN ntac (search d' (n-1) local_db)) (possible_resolve sigma d mod_delta db_list local_db secvars concl)) - end })) + end)) end [] in search d n local_db @@ -502,7 +502,7 @@ let search d n mod_delta db_list local_db = let default_search_depth = ref 5 let delta_auto debug mod_delta n lems dbnames = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = make_db_list dbnames in @@ -510,7 +510,7 @@ let delta_auto debug mod_delta n lems dbnames = let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (search d n mod_delta db_list hints) - end } + end let delta_auto = if Flags.profile then @@ -525,7 +525,7 @@ let new_auto ?(debug=Off) n = delta_auto debug true n let default_auto = auto !default_search_depth [] [] let delta_full_auto ?(debug=Off) mod_delta n lems = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = current_pure_db () in @@ -533,7 +533,7 @@ let delta_full_auto ?(debug=Off) mod_delta n lems = let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (search d n mod_delta db_list hints) - end } + end let full_auto ?(debug=Off) n = delta_full_auto ~debug false n let new_full_auto ?(debug=Off) n = delta_full_auto ~debug true n diff --git a/tactics/auto.mli b/tactics/auto.mli index 9ed9f0ae2..a6fb82bab 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -16,14 +16,14 @@ open Decl_kinds open Hints open Tactypes -val compute_secvars : ('a,'b) Proofview.Goal.t -> Id.Pred.t +val compute_secvars : 'a Proofview.Goal.t -> Id.Pred.t val default_search_depth : int ref val auto_flags_of_state : transparent_state -> Unification.unify_flags val connect_hint_clenv : polymorphic -> raw_hint -> clausenv -> - ('a, 'r) Proofview.Goal.t -> clausenv * constr + 'a Proofview.Goal.t -> clausenv * constr (** Try unification with the precompiled clause, then use registered Apply *) val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clausenv) -> unit Proofview.tactic diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index de544fe5f..2d4f20276 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -15,7 +15,6 @@ open CErrors open Util open Mod_subst open Locus -open Proofview.Notations (* Rewriting rules *) type rew_rule = { rew_lemma: constr; @@ -90,15 +89,14 @@ type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_gen let one_base general_rewrite_maybe_in tac_main bas = let lrul = find_rewrites bas in let try_rewrite dir ctx c tc = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in let c' = Vars.subst_univs_level_constr subst c in - let sigma = Sigma.to_evar_map sigma in let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in - let tac = general_rewrite_maybe_in dir c' tc in - Sigma.Unsafe.of_pair (tac, sigma) - end } in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (general_rewrite_maybe_in dir c' tc) + end in let lrul = List.map (fun h -> let tac = match h.rew_tac with | None -> Proofview.tclUNIT () @@ -125,7 +123,7 @@ let autorewrite ?(conds=Naive) tac_main lbas = (Proofview.tclUNIT()) lbas)) let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> (* let's check at once if id exists (to raise the appropriate error) *) let _ = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) idl in let general_rewrite_in id dir cstr tac = @@ -137,7 +135,7 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = (List.fold_left (fun tac bas -> Tacticals.New.tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) (Proofview.tclUNIT()) lbas))) idl - end } + end let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id] @@ -162,10 +160,10 @@ let gen_auto_multi_rewrite conds tac_main lbas cl = | None -> (* try to rewrite in all hypothesis (except maybe the rewritten one) *) - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let ids = Tacmach.New.pf_ids_of_hyps gl in try_do_hyps (fun id -> id) ids - end }) + end) let auto_multi_rewrite ?(conds=Naive) lems cl = Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds (Proofview.tclUNIT()) lems cl) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 672f9cffb..de49a521f 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -211,7 +211,7 @@ let auto_unif_flags freeze st = let e_give_exact flags poly (c,clenv) = let open Tacmach.New in - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in let (c, _, _) = c in let c, sigma = @@ -223,34 +223,34 @@ let e_give_exact flags poly (c,clenv) = else c, sigma in let (sigma, t1) = Typing.type_of (pf_env gl) sigma c in - Sigma.Unsafe.of_pair (Clenvtac.unify ~flags t1 <*> exact_no_check c, sigma) - end } + Proofview.Unsafe.tclEVARS sigma <*> + Clenvtac.unify ~flags t1 <*> exact_no_check c + end let clenv_unique_resolver_tac with_evars ~flags clenv' = - Proofview.Goal.enter { enter = begin fun gls -> + Proofview.Goal.enter begin fun gls -> let resolve = try Proofview.tclUNIT (clenv_unique_resolver ~flags clenv' gls) with e -> Proofview.tclZERO e in resolve >>= fun clenv' -> Clenvtac.clenv_refine with_evars ~with_classes:false clenv' - end } + end -let unify_e_resolve poly flags = { enter = begin fun gls (c,_,clenv) -> +let unify_e_resolve poly flags = begin fun gls (c,_,clenv) -> let clenv', c = connect_hint_clenv poly c clenv gls in - clenv_unique_resolver_tac true ~flags clenv' end } + clenv_unique_resolver_tac true ~flags clenv' end -let unify_resolve poly flags = { enter = begin fun gls (c,_,clenv) -> +let unify_resolve poly flags = begin fun gls (c,_,clenv) -> let clenv', _ = connect_hint_clenv poly c clenv gls in clenv_unique_resolver_tac false ~flags clenv' - end } + end (** Application of a lemma using [refine] instead of the old [w_unify] *) let unify_resolve_refine poly flags gls ((c, t, ctx),n,clenv) = let open Clenv in let env = Proofview.Goal.env gls in let concl = Proofview.Goal.concl gls in - Refine.refine ~unsafe:true { Sigma.run = fun sigma -> - let sigma = Sigma.to_evar_map sigma in + Refine.refine ~unsafe:true begin fun sigma -> let sigma, term, ty = if poly then let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in @@ -266,7 +266,7 @@ let unify_resolve_refine poly flags gls ((c, t, ctx),n,clenv) = let sigma' = Evarconv.the_conv_x_leq env ~ts:flags.core_unify_flags.modulo_delta cl.cl_concl concl sigma' - in Sigma.here term (Sigma.Unsafe.of_evar_map sigma') } + in (sigma', term) end let unify_resolve_refine poly flags gl clenv = Proofview.tclORELSE @@ -297,32 +297,31 @@ let clenv_of_prods poly nprods (c, clenv) gl = let with_prods nprods poly (c, clenv) f = if get_typeclasses_limit_intros () then - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> try match clenv_of_prods poly nprods (c, clenv) gl with | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") - | Some (diff, clenv') -> f.enter gl (c, diff, clenv') + | Some (diff, clenv') -> f gl (c, diff, clenv') with e when CErrors.noncritical e -> - Tacticals.New.tclZEROMSG (CErrors.print e) end } + Tacticals.New.tclZEROMSG (CErrors.print e) end else Proofview.Goal.enter - { enter = begin fun gl -> - if Int.equal nprods 0 then f.enter gl (c, None, clenv) - else Tacticals.New.tclZEROMSG (str"Not enough premisses") end } + begin fun gl -> + if Int.equal nprods 0 then f gl (c, None, clenv) + else Tacticals.New.tclZEROMSG (str"Not enough premisses") end let matches_pattern concl pat = let matches env sigma = match pat with | None -> Proofview.tclUNIT () | Some pat -> - let sigma = Sigma.to_evar_map sigma in if Constr_matching.is_matching env sigma pat concl then Proofview.tclUNIT () else Tacticals.New.tclZEROMSG (str "pattern does not match") in - Proofview.Goal.enter { enter = fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - matches env sigma } + matches env sigma end (** Semantics of type class resolution lemma application: @@ -363,7 +362,7 @@ let rec e_trivial_fail_db only_classes db_list local_db secvars = let open Tacticals.New in let open Tacmach.New in let trivial_fail = - Proofview.Goal.enter { enter = + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -371,15 +370,15 @@ let rec e_trivial_fail_db only_classes db_list local_db secvars = let hintl = make_resolve_hyp env sigma d in let hints = Hint_db.add_list env sigma hintl local_db in e_trivial_fail_db only_classes db_list hints secvars - end } + end in let trivial_resolve = - Proofview.Goal.enter { enter = + Proofview.Goal.enter begin fun gl -> let tacs = e_trivial_resolve db_list local_db secvars only_classes (project gl) (pf_concl gl) in tclFIRST (List.map (fun (x,_,_,_,_) -> x) tacs) - end} + end in let tacl = Eauto.registered_e_assumption :: @@ -418,9 +417,9 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes sigma co if get_typeclasses_filtered_unification () then let tac = with_prods nprods poly (term,cl) - ({ enter = fun gl clenv -> + (fun gl clenv -> matches_pattern concl p <*> - unify_resolve_refine poly flags gl clenv}) + unify_resolve_refine poly flags gl clenv) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else let tac = @@ -433,9 +432,9 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes sigma co | ERes_pf (term,cl) -> if get_typeclasses_filtered_unification () then let tac = (with_prods nprods poly (term,cl) - ({ enter = fun gl clenv -> + (fun gl clenv -> matches_pattern concl p <*> - unify_resolve_refine poly flags gl clenv})) in + unify_resolve_refine poly flags gl clenv)) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else let tac = @@ -450,7 +449,7 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes sigma co let tac = matches_pattern concl p <*> Proofview.Goal.nf_enter - { enter = fun gl -> unify_resolve_refine poly flags gl (c,None,clenv) } in + (fun gl -> unify_resolve_refine poly flags gl (c,None,clenv)) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else e_give_exact flags poly (c,clenv) @@ -1039,16 +1038,16 @@ module Search = struct sigma goals let fail_if_nonclass info = - Proofview.Goal.enter { enter = fun gl -> + Proofview.Goal.enter begin fun gl -> let gl = Proofview.Goal.assume gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let sigma = Proofview.Goal.sigma gl in if is_class_type sigma (Proofview.Goal.concl gl) then Proofview.tclUNIT () else (if !typeclasses_debug > 1 then Feedback.msg_debug (pr_depth info.search_depth ++ str": failure due to non-class subgoal " ++ pr_ev sigma (Proofview.Goal.goal gl)); - Proofview.tclZERO NoApplicableEx) } + Proofview.tclZERO NoApplicableEx) end (** The general hint application tactic. tac1 + tac2 .... The choice of OR or ORELSE is determined @@ -1060,18 +1059,17 @@ module Search = struct let env = Goal.env gl in let concl = Goal.concl gl in let sigma = Goal.sigma gl in - let s = Sigma.to_evar_map sigma in - let unique = not info.search_dep || is_unique env s concl in - let backtrack = needs_backtrack env s unique concl in + let unique = not info.search_dep || is_unique env sigma concl in + let backtrack = needs_backtrack env sigma unique concl in if !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth info.search_depth ++ str": looking for " ++ - Printer.pr_econstr_env (Goal.env gl) s concl ++ + Printer.pr_econstr_env (Goal.env gl) sigma concl ++ (if backtrack then str" with backtracking" else str" without backtracking")); let secvars = compute_secvars gl in let poss = - e_possible_resolve hints info.search_hints secvars info.search_only_classes s concl in + e_possible_resolve hints info.search_hints secvars info.search_only_classes sigma concl in (* If no goal depends on the solution of this one or the instances are irrelevant/assumed to be unique, then we don't need to backtrack, as long as no evar appears in the goal @@ -1089,7 +1087,7 @@ module Search = struct pr_depth (idx :: info.search_depth) ++ str": " ++ Lazy.force pp ++ (if !foundone != true then - str" on" ++ spc () ++ pr_ev s (Proofview.Goal.goal (Proofview.Goal.assume gl)) + str" on" ++ spc () ++ pr_ev sigma (Proofview.Goal.goal (Proofview.Goal.assume gl)) else mt ()) in let msg = @@ -1104,15 +1102,14 @@ module Search = struct Feedback.msg_debug (header ++ str " failed with: " ++ msg) else () in - let tac_of gls i j = Goal.enter { enter = fun gl' -> + let tac_of gls i j = Goal.enter begin fun gl' -> let sigma' = Goal.sigma gl' in - let s' = Sigma.to_evar_map sigma' in let _concl = Goal.concl gl' in if !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth (succ j :: i :: info.search_depth) ++ str" : " ++ - pr_ev s' (Proofview.Goal.goal (Proofview.Goal.assume gl'))); - let eq c1 c2 = EConstr.eq_constr s' c1 c2 in + pr_ev sigma' (Proofview.Goal.goal (Proofview.Goal.assume gl'))); + let eq c1 c2 = EConstr.eq_constr sigma' c1 c2 in let hints' = if b && not (Context.Named.equal eq (Goal.hyps gl') (Goal.hyps gl)) then @@ -1120,7 +1117,7 @@ module Search = struct make_autogoal_hints info.search_only_classes ~st gl' else info.search_hints in - let dep' = info.search_dep || Proofview.unifiable s' (Goal.goal (Proofview.Goal.assume gl')) gls in + let dep' = info.search_dep || Proofview.unifiable sigma' (Goal.goal (Proofview.Goal.assume gl')) gls in let info' = { search_depth = succ j :: i :: info.search_depth; last_tac = pp; @@ -1128,7 +1125,7 @@ module Search = struct search_only_classes = info.search_only_classes; search_hints = hints'; search_cut = derivs } - in kont info' } + in kont info' end in let rec result (shelf, ()) i k = foundone := true; @@ -1137,7 +1134,7 @@ module Search = struct (if !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth (i :: info.search_depth) ++ str": " ++ Lazy.force pp - ++ str" on" ++ spc () ++ pr_ev s (Proofview.Goal.goal (Proofview.Goal.assume gl)) + ++ str" on" ++ spc () ++ pr_ev sigma (Proofview.Goal.goal (Proofview.Goal.assume gl)) ++ str", " ++ int j ++ str" subgoal(s)" ++ (Option.cata (fun k -> str " in addition to the first " ++ int k) (mt()) k))); @@ -1207,7 +1204,7 @@ module Search = struct if !foundone == false && !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth info.search_depth ++ str": no match for " ++ - Printer.pr_econstr_env (Goal.env gl) s concl ++ + Printer.pr_econstr_env (Goal.env gl) sigma concl ++ str ", " ++ int (List.length poss) ++ str" possibilities"); match e with @@ -1219,18 +1216,17 @@ module Search = struct let hints_tac hints info kont : unit Proofview.tactic = Proofview.Goal.enter - { enter = fun gl -> hints_tac_gl hints info kont gl } + (fun gl -> hints_tac_gl hints info kont gl) let intro_tac info kont gl = let open Proofview in let env = Goal.env gl in let sigma = Goal.sigma gl in - let s = Sigma.to_evar_map sigma in let decl = Tacmach.New.pf_last_hyp gl in let hint = - make_resolve_hyp env s (Hint_db.transparent_state info.search_hints) + make_resolve_hyp env sigma (Hint_db.transparent_state info.search_hints) (true,false,false) info.search_only_classes empty_hint_info decl in - let ldb = Hint_db.add_list env s hint info.search_hints in + let ldb = Hint_db.add_list env sigma hint info.search_hints in let info' = { info with search_hints = ldb; last_tac = lazy (str"intro"); search_depth = 1 :: 1 :: info.search_depth } @@ -1238,7 +1234,7 @@ module Search = struct let intro info kont = Proofview.tclBIND Tactics.intro - (fun _ -> Proofview.Goal.enter { enter = fun gl -> intro_tac info kont gl }) + (fun _ -> Proofview.Goal.enter (fun gl -> intro_tac info kont gl)) let rec search_tac hints limit depth = let kont info = @@ -1271,8 +1267,8 @@ module Search = struct let open Proofview in let tac sigma gls i = Goal.enter - { enter = fun gl -> - search_tac_gl ~st only_classes dep hints depth (succ i) sigma gls gl } + begin fun gl -> + search_tac_gl ~st only_classes dep hints depth (succ i) sigma gls gl end in Proofview.Unsafe.tclGETGOALS >>= fun gls -> Proofview.tclEVARMAP >>= fun sigma -> @@ -1627,13 +1623,13 @@ let is_ground c = let autoapply c i = let open Proofview.Notations in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let flags = auto_unif_flags Evar.Set.empty (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in let cty = Tacmach.New.pf_unsafe_type_of gl c in let ce = mk_clenv_from gl (c,cty) in - (unify_e_resolve false flags).enter gl + unify_e_resolve false flags gl ((c,cty,Univ.ContextSet.empty),0,ce) <*> Proofview.tclEVARMAP >>= (fun sigma -> let sigma = Typeclasses.mark_unresolvables ~filter:Typeclasses.all_goals sigma in - Proofview.Unsafe.tclEVARS sigma) end } + Proofview.Unsafe.tclEVARS sigma) end diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 5e7090ded..83c2be410 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -25,22 +25,20 @@ let mk_absurd_proof coq_not t = mkLambda (Names.Name id,t,mkApp (mkRel 2,[|mkRel 1|]))) let absurd c = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map sigma in let j = Retyping.get_judgment_of env sigma c in let sigma, j = Coercion.inh_coerce_to_sort env sigma j in let t = j.Environ.utj_val in - let tac = + Proofview.Unsafe.tclEVARS sigma <*> Tacticals.New.pf_constr_of_global (build_coq_not ()) >>= fun coqnot -> Tacticals.New.pf_constr_of_global (build_coq_False ()) >>= fun coqfalse -> Tacticals.New.tclTHENLIST [ elim_type coqfalse; Simple.apply (mk_absurd_proof coqnot t) - ] in - Sigma.Unsafe.of_pair (tac, sigma) - end } + ] + end let absurd c = absurd c @@ -54,13 +52,13 @@ let filter_hyp f tac = | [] -> Proofview.tclZERO Not_found | d::rest when f (NamedDecl.get_type d) -> tac (NamedDecl.get_id d) | _::rest -> seek rest in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in seek hyps - end } + end let contradiction_context = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let rec seek_neg l = match l with @@ -89,11 +87,11 @@ let contradiction_context = | None -> Tacticals.New.tclZEROMSG (Pp.str"Not a negated unit type.")) (Proofview.tclORELSE - (Proofview.Goal.enter { enter = begin fun gl -> + (Proofview.Goal.enter begin fun gl -> let is_conv_leq = Tacmach.New.pf_apply is_conv_leq gl in filter_hyp (fun typ -> is_conv_leq typ t) (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|]))) - end }) + end) begin function (e, info) -> match e with | Not_found -> seek_neg rest | e -> Proofview.tclZERO ~info e @@ -102,7 +100,7 @@ let contradiction_context = in let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in seek_neg hyps - end } + end let is_negation_of env sigma typ t = match EConstr.kind sigma (whd_all env sigma t) with @@ -111,7 +109,7 @@ let is_negation_of env sigma typ t = | _ -> false let contradiction_term (c,lbind as cl) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in @@ -134,7 +132,7 @@ let contradiction_term (c,lbind as cl) = | Not_found -> Tacticals.New.tclZEROMSG (Pp.str"Not a contradiction.") | e -> Proofview.tclZERO ~info e end - end } + end let contradiction = function | None -> Tacticals.New.tclTHEN intros contradiction_context diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 986f53139..bae334461 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -30,27 +30,27 @@ open Proofview.Notations let eauto_unif_flags = auto_flags_of_state full_transparent_state let e_give_exact ?(flags=eauto_unif_flags) c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let t1 = Tacmach.New.pf_unsafe_type_of gl c in let t2 = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in let sigma = Tacmach.New.project gl in if occur_existential sigma t1 || occur_existential sigma t2 then Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) else exact_check c - end } + end let assumption id = e_give_exact (mkVar id) let e_assumption = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> Tacticals.New.tclFIRST (List.map assumption (Tacmach.New.pf_ids_of_hyps gl)) - end } + end let registered_e_assumption = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (mkVar id)) (Tacmach.New.pf_ids_of_hyps gl)) - end } + end (************************************************************************) (* PROLOG tactic *) @@ -93,7 +93,7 @@ let out_term = function let prolog_tac l n = Proofview.V82.tactic begin fun gl -> let map c = - let (c, sigma) = Tactics.run_delayed (pf_env gl) (project gl) c in + let (sigma, c) = c (pf_env gl) (project gl) in let c = pf_apply (prepare_hint false (false,true)) gl (sigma, c) in out_term c in @@ -112,13 +112,13 @@ open Auto let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) let unify_e_resolve poly flags (c,clenv) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let clenv', c = connect_hint_clenv poly c clenv gl in let clenv' = clenv_unique_resolver ~flags clenv' gl in Proofview.tclTHEN (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) (Tactics.Simple.eapply c) - end } + end let hintmap_of sigma secvars hdc concl = match hdc with @@ -130,20 +130,20 @@ let hintmap_of sigma secvars hdc concl = (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) let e_exact poly flags (c,clenv) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let clenv', c = connect_hint_clenv poly c clenv gl in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) (e_give_exact c) - end } + end let rec e_trivial_fail_db db_list local_db = - let next = Proofview.Goal.enter { enter = begin fun gl -> + let next = Proofview.Goal.enter begin fun gl -> let d = Tacmach.New.pf_last_hyp gl in let hintl = make_resolve_hyp (Tacmach.New.pf_env gl) (Tacmach.New.project gl) d in e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Tacmach.New.project gl) hintl local_db) - end } in - Proofview.Goal.enter { enter = begin fun gl -> + end in + Proofview.Goal.enter begin fun gl -> let secvars = compute_secvars gl in let tacl = registered_e_assumption :: @@ -151,7 +151,7 @@ let rec e_trivial_fail_db db_list local_db = (List.map fst (e_trivial_resolve (Tacmach.New.project gl) db_list local_db secvars (Tacmach.New.pf_concl gl))) in Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) - end } + end and e_my_find_search sigma db_list local_db secvars hdc concl = let hint_of_db = hintmap_of sigma secvars hdc concl in @@ -497,7 +497,7 @@ let unfold_head env sigma (ids, csts) c = in aux c let autounfold_one db cl = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in @@ -517,4 +517,4 @@ let autounfold_one db cl = | Some hyp -> change_in_hyp None (make_change_arg c') hyp | None -> convert_concl_no_check c' DEFAULTcast else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") - end } + end diff --git a/tactics/elim.ml b/tactics/elim.ml index 855cb206f..13d64b8e3 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -77,7 +77,7 @@ let tmphyp_name = Id.of_string "_TmpHyp" let up_to_delta = ref false (* true *) let general_decompose recognizer c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let type_of = pf_unsafe_type_of gl in let sigma = project gl in let typc = type_of c in @@ -87,7 +87,7 @@ let general_decompose recognizer c = (ifOnHyp (recognizer sigma) (general_decompose_aux (recognizer sigma)) (fun id -> clear [id]))); exact_no_check c ] - end } + end let head_in indl t gl = let env = Proofview.Goal.env gl in @@ -101,10 +101,10 @@ let head_in indl t gl = with Not_found -> false let decompose_these c l = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let indl = List.map (fun x -> x, Univ.Instance.empty) l in general_decompose (fun sigma (_,t) -> head_in indl t gl) c - end } + end let decompose_and c = general_decompose @@ -132,7 +132,7 @@ let induction_trailer abs_i abs_j bargs = (tclDO (abs_j - abs_i) intro) (onLastHypId (fun id -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let idty = pf_unsafe_type_of gl (mkVar id) in let fvty = global_vars (pf_env gl) (project gl) idty in let possible_bring_hyps = @@ -150,11 +150,11 @@ let induction_trailer abs_i abs_j bargs = let ids = List.rev (ids_of_named_context hyps) in (tclTHENLIST [revert ids; simple_elimination (mkVar id)]) - end } + end )) let double_ind h1 h2 = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let abs_i = depth_of_quantified_hypothesis true h1 gl in let abs_j = depth_of_quantified_hypothesis true h2 gl in let abs = @@ -167,7 +167,7 @@ let double_ind h1 h2 = (fun id -> elimination_then (introElimAssumsThen (induction_trailer abs_i abs_j)) (mkVar id)))) - end } + end let h_double_induction = double_ind diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 93073fdc7..466b1350d 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -18,7 +18,6 @@ open Indrec open Declarations open Typeops open Ind_tables -open Sigma.Notations (* Induction/recursion schemes *) @@ -109,10 +108,10 @@ let rec_dep_scheme_kind_from_type = let build_case_analysis_scheme_in_type dep sort ind = let env = Global.env () in - let sigma = Sigma.Unsafe.of_evar_map (Evd.from_env env) in - let Sigma (indu, sigma, _) = Sigma.fresh_inductive_instance env sigma ind in - let Sigma (c, sigma, _) = build_case_analysis_scheme env sigma indu dep sort in - c, Evd.evar_universe_context (Sigma.to_evar_map sigma) + let sigma = Evd.from_env env in + let (sigma, indu) = Evd.fresh_inductive_instance env sigma ind in + let (sigma, c) = build_case_analysis_scheme env sigma indu dep sort in + c, Evd.evar_universe_context sigma let case_scheme_kind_from_type = declare_individual_scheme_object "_case_nodep" diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 48ce52f09..0cee4b6ed 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -23,7 +23,6 @@ open Tacticals.New open Auto open Constr_matching open Misctypes -open Tactypes open Hipattern open Proofview.Notations open Tacmach.New @@ -66,22 +65,20 @@ let choose_noteq eqonleft = else left_with_bindings false Misctypes.NoBindings -open Sigma.Notations - (* A surgical generalize which selects the right occurrences by hand *) (* This prevents issues where c2 is also a subterm of c1 (see e.g. #5449) *) let generalize_right mk typ c1 c2 = - Proofview.Goal.enter { Proofview.Goal.enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in - Refine.refine ~unsafe:true { Sigma.run = begin fun sigma -> + Refine.refine ~unsafe:true begin fun sigma -> let na = Name (next_name_away_with_default "x" Anonymous (Termops.ids_of_context env)) in let newconcl = mkProd (na, typ, mk typ c1 (mkRel 1)) in - let Sigma (x, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store newconcl in - Sigma (mkApp (x, [|c2|]), sigma, p) - end } - end } + let (sigma, x) = Evarutil.new_evar env sigma ~principal:true ~store newconcl in + (sigma, mkApp (x, [|c2|])) + end + end let mkBranches (eqonleft,mk,c1,c2,typ) = tclTHENLIST @@ -93,7 +90,7 @@ let mkBranches (eqonleft,mk,c1,c2,typ) = intros] let discrHyp id = - let c = { delayed = fun env sigma -> Sigma.here (mkVar id, NoBindings) sigma } in + let c env sigma = (sigma, (mkVar id, NoBindings)) in let tac c = Equality.discr_tac false (Some (None, ElimOnConstr c)) in Tacticals.New.tclDELAYEDWITHHOLES false c tac @@ -138,7 +135,7 @@ let eqCase tac = tclTHEN intro (onLastHypId tac) let injHyp id = - let c = { delayed = fun env sigma -> Sigma.here (mkVar id, NoBindings) sigma } in + let c env sigma = (sigma, (mkVar id, NoBindings)) in let tac c = Equality.injClause None false (Some (None, ElimOnConstr c)) in Tacticals.New.tclDELAYEDWITHHOLES false c tac @@ -189,7 +186,7 @@ let rec solveArg hyps eqonleft mk largs rargs = match largs, rargs with intros_reflexivity; ] | a1 :: largs, a2 :: rargs -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let rectype = pf_unsafe_type_of gl a1 in let decide = mk rectype a1 a2 in let tac hyp = solveArg (hyp :: hyps) eqonleft mk largs rargs in @@ -197,13 +194,13 @@ let rec solveArg hyps eqonleft mk largs rargs = match largs, rargs with if eqonleft then [eqCase tac;diseqCase hyps eqonleft;default_auto] else [diseqCase hyps eqonleft;eqCase tac;default_auto] in (tclTHENS (elim_type decide) subtacs) - end } + end | _ -> invalid_arg "List.fold_right2" let solveEqBranch rectype = Proofview.tclORELSE begin - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = pf_concl gl in let sigma = project gl in match_eqdec sigma concl >>= fun (eqonleft,mk,lhs,rhs,_) -> @@ -212,8 +209,9 @@ let solveEqBranch rectype = let getargs l = List.skipn nparams (snd (decompose_app sigma l)) in let rargs = getargs rhs and largs = getargs lhs in + solveArg [] eqonleft mk largs rargs - end } + end end begin function (e, info) -> match e with | PatternMatchingFailure -> Tacticals.New.tclZEROMSG (Pp.str"Unexpected conclusion!") @@ -229,7 +227,7 @@ let hd_app sigma c = match EConstr.kind sigma c with let decideGralEquality = Proofview.tclORELSE begin - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = pf_concl gl in let sigma = project gl in match_eqdec sigma concl >>= fun (eqonleft,mk,c1,c2,typ as data) -> @@ -241,7 +239,7 @@ let decideGralEquality = (tclTHEN (mkBranches data) (tclORELSE (solveNoteqBranch eqonleft) (solveEqBranch rectype))) - end } + end end begin function (e, info) -> match e with | PatternMatchingFailure -> @@ -252,10 +250,10 @@ let decideGralEquality = let decideEqualityGoal = tclTHEN intros decideGralEquality let decideEquality rectype ops = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let decide = mkGenDecideEqGoal rectype ops gl in (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) - end } + end (* The tactic Compare *) @@ -264,7 +262,7 @@ let compare c1 c2 = pf_constr_of_global (build_coq_sumbool ()) >>= fun opc -> pf_constr_of_global (Coqlib.build_coq_eq ()) >>= fun eqc -> pf_constr_of_global (build_coq_not ()) >>= fun notc -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let rectype = pf_unsafe_type_of gl c1 in let ops = (opc,eqc,notc) in let decide = mkDecideEqGoal true ops rectype c1 c2 in @@ -272,4 +270,4 @@ let compare c1 c2 = [(tclTHEN intro (tclTHEN (onLastHyp simplest_case) clear_last)); decideEquality rectype ops]) - end } + end diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 507ff10ee..efcefcf16 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -57,7 +57,6 @@ open Namegen open Inductiveops open Ind_tables open Indrec -open Sigma.Notations open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration @@ -656,10 +655,10 @@ let fix_r2l_forward_rew_scheme (c, ctx') = (**********************************************************************) let build_r2l_rew_scheme dep env ind k = - let sigma = Sigma.Unsafe.of_evar_map (Evd.from_env env) in - let Sigma (indu, sigma, _) = Sigma.fresh_inductive_instance env sigma ind in - let Sigma (c, sigma, _) = build_case_analysis_scheme env sigma indu dep k in - c, Evd.evar_universe_context (Sigma.to_evar_map sigma) + let sigma = Evd.from_env env in + let (sigma, indu) = Evd.fresh_inductive_instance env sigma ind in + let (sigma, c) = build_case_analysis_scheme env sigma indu dep k in + c, Evd.evar_universe_context sigma let build_l2r_rew_scheme = build_l2r_rew_scheme let build_l2r_forward_rew_scheme = build_l2r_forward_rew_scheme diff --git a/tactics/equality.ml b/tactics/equality.ml index d64cc38ef..05c5cd5ec 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -40,7 +40,6 @@ open Eqschemes open Locus open Locusops open Misctypes -open Sigma.Notations open Proofview.Notations open Unification open Context.Named.Declaration @@ -254,16 +253,16 @@ let rewrite_keyed_unif_flags = { } let rewrite_elim with_evars frzevars cls c e = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let flags = if Unification.is_keyed_unification () then rewrite_keyed_unif_flags else rewrite_conv_closed_unif_flags in let flags = make_flags frzevars (Tacmach.New.project gl) flags c in general_elim_clause with_evars flags cls c e - end } + end let tclNOTSAMEGOAL tac = let goal gl = Proofview.Goal.goal (Proofview.Goal.assume gl) in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let sigma = project gl in let ev = goal gl in tac >>= fun () -> @@ -278,7 +277,7 @@ let tclNOTSAMEGOAL tac = tclZEROMSG (str"Tactic generated a subgoal identical to the original goal.") else Proofview.tclUNIT () - end } + end (* Ad hoc asymmetric general_elim_clause *) let general_elim_clause with_evars frzevars cls rew elim = @@ -313,7 +312,7 @@ let general_elim_clause with_evars frzevars tac cls c t l l2r elim = (general_elim_clause with_evars frzevars cls c elim)) tac in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let instantiate_lemma concl = if not all then instantiate_lemma gl c t l l2r concl else instantiate_lemma_all frzevars gl c t l l2r concl @@ -325,7 +324,7 @@ let general_elim_clause with_evars frzevars tac cls c t l l2r elim = let cs = instantiate_lemma typ in if firstonly then tclFIRST (List.map try_clause cs) else tclMAP try_clause cs - end } + end (* The next function decides in particular whether to try a regular rewrite or a generalized rewrite. @@ -387,9 +386,9 @@ let find_elim hdcncl lft2rgt dep cls ot gl = Logic.eq or Jmeq just before *) assert false in - let Sigma (elim, sigma, p) = Sigma.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in + let (sigma, elim) = fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in let elim = EConstr.of_constr elim in - Sigma ((elim, Safe_typing.empty_private_constants), sigma, p) + (sigma, (elim, Safe_typing.empty_private_constants)) else let scheme_name = match dep, lft2rgt, inccl with (* Non dependent case *) @@ -407,11 +406,11 @@ let find_elim hdcncl lft2rgt dep cls ot gl = | Ind (ind,u) -> let c, eff = find_scheme scheme_name ind in (* MS: cannot use pf_constr_of_global as the eliminator might be generated by side-effect *) - let Sigma (elim, sigma, p) = - Sigma.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) + let (sigma, elim) = + fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in let elim = EConstr.of_constr elim in - Sigma ((elim, eff), sigma, p) + (sigma, (elim, eff)) | _ -> assert false let type_of_clause cls gl = match cls with @@ -419,21 +418,19 @@ let type_of_clause cls gl = match cls with | Some id -> pf_get_hyp_typ id gl let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = - Proofview.Goal.s_enter { s_enter = begin fun gl -> - let evd = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + Proofview.Goal.enter begin fun gl -> + let evd = Proofview.Goal.sigma gl in let isatomic = isProd evd (whd_zeta evd hdcncl) in let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in let dep = dep_proof_ok && dep_fun evd c type_of_cls in - let Sigma ((elim, effs), sigma, p) = find_elim hdcncl lft2rgt dep cls (Some t) gl in - let tac = + let (sigma, (elim, effs)) = find_elim hdcncl lft2rgt dep cls (Some t) gl in + Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclEFFECTS effs <*> general_elim_clause with_evars frzevars tac cls c t l (match lft2rgt with None -> false | Some b -> b) {elimindex = None; elimbody = (elim,NoBindings); elimrename = None} - in - Sigma (tac, sigma, p) - end } + end let adjust_rewriting_direction args lft2rgt = match args with @@ -456,7 +453,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac if occs != AllOccurrences then ( rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac) else - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let ctype = get_type_of env sigma c in @@ -485,7 +482,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac | None -> Proofview.tclZERO ~info e (* error "The provided term does not end with an equality or a declared rewrite relation." *) end - end } + end let general_rewrite_ebindings = general_rewrite_ebindings_clause None @@ -547,9 +544,9 @@ let general_rewrite_clause l2r with_evars ?tac c cl = let ids_of_hyps = pf_ids_of_hyps gl in Id.Set.fold (fun id l -> List.remove Id.equal id l) ids_in_c ids_of_hyps in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> do_hyps_atleastonce (ids gl) - end } + end in if cl.concl_occs == NoOccurrences then do_hyps else tclIFTHENTRYELSEMUST @@ -557,25 +554,25 @@ let general_rewrite_clause l2r with_evars ?tac c cl = do_hyps let apply_special_clear_request clear_flag f = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try - let ((c, bl), sigma) = run_delayed env sigma f in + let (sigma, (c, bl)) = f env sigma in apply_clear_request clear_flag (use_clear_hyp_by_default ()) c with e when catchable_exception e -> tclIDTAC - end } + end let general_multi_rewrite with_evars l cl tac = let do1 l2r f = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in - let (c, sigma) = run_delayed env sigma f in + let (sigma, c) = f env sigma in tclWITHHOLES with_evars (general_rewrite_clause l2r with_evars ?tac c cl) sigma - end } + end in let rec doN l2r c = function | Precisely n when n <= 0 -> Proofview.tclUNIT () @@ -638,7 +635,7 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = | None -> Proofview.tclUNIT () | Some tac -> tclCOMPLETE tac in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let get_type_of = pf_apply get_type_of gl in let t1 = get_type_of c1 and t2 = get_type_of c2 in @@ -664,7 +661,7 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = tclTHEN (apply sym) assumption; try_prove_eq ]) - end } + end let replace c1 c2 = replace_using_leibniz onConcl c2 c1 false false None @@ -934,13 +931,9 @@ let build_selector env sigma dirn c ind special default = let ci = make_case_info env ind RegularStyle in sigma, mkCase (ci, p, c, Array.of_list brl) -let new_global sigma gr = - let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map sigma) gr - in Sigma.to_evar_map sigma, c - -let build_coq_False sigma = new_global sigma (build_coq_False ()) -let build_coq_True sigma = new_global sigma (build_coq_True ()) -let build_coq_I sigma = new_global sigma (build_coq_I ()) +let build_coq_False sigma = Evarutil.new_global sigma (build_coq_False ()) +let build_coq_True sigma = Evarutil.new_global sigma (build_coq_True ()) +let build_coq_I sigma = Evarutil.new_global sigma (build_coq_I ()) let rec build_discriminator env sigma dirn c = function | [] -> @@ -967,7 +960,7 @@ let rec build_discriminator env sigma dirn c = function *) let gen_absurdity id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in let hyp_typ = pf_get_hyp_typ id (Proofview.Goal.assume gl) in if is_empty_type sigma hyp_typ @@ -975,7 +968,7 @@ let gen_absurdity id = simplest_elim (mkVar id) else tclZEROMSG (str "Not the negation of an equality.") - end } + end (* Precondition: eq is leibniz equality @@ -1032,17 +1025,17 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in match find_positions env sigma ~no_discr:false t1 t2 with | Inr _ -> tclZEROMSG (str"Not a discriminable equality.") | Inl (cpath, (_,dirn), _) -> discr_positions env sigma u eq_clause cpath dirn - end } + end let onEquality with_evars tac (c,lbindc) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let type_of = pf_unsafe_type_of gl in let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in let t = type_of c in @@ -1054,10 +1047,10 @@ let onEquality with_evars tac (c,lbindc) = tclTHEN (Proofview.Unsafe.tclEVARS eq_clause'.evd) (tac (eq,eqn,eq_args) eq_clause') - end } + end let onNegatedEquality with_evars tac = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let ccl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in @@ -1068,7 +1061,7 @@ let onNegatedEquality with_evars tac = onEquality with_evars tac (mkVar id,NoBindings))) | _ -> tclZEROMSG (str "Not a negated primitive equality.") - end } + end let discrSimpleClause with_evars = function | None -> onNegatedEquality with_evars discrEq @@ -1327,7 +1320,7 @@ let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined") let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k) let inject_if_homogenous_dependent_pair ty = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> try let sigma = Tacmach.New.project gl in let eq,u,(t,t1,t2) = find_this_eq_data_decompose gl ty in @@ -1367,7 +1360,7 @@ let inject_if_homogenous_dependent_pair ty = ])] with Exit -> Proofview.tclUNIT () - end } + end (* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it expands then only when the whdnf has a constructor of an inductive type @@ -1451,7 +1444,7 @@ let injEq ?(old=false) with_evars clear_flag ipats = let post_tac c n = match ipats_style with | Some ipats -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in let destopt = match EConstr.kind sigma c with | Var id -> get_previous_hyp_position id gl @@ -1464,7 +1457,7 @@ let injEq ?(old=false) with_evars clear_flag ipats = then intro_patterns_bound_to with_evars n destopt ipats else intro_patterns_to with_evars destopt ipats in tclTHEN clear_tac intro_tac - end } + end | None -> tclIDTAC in injEqThen post_tac l2r @@ -1482,7 +1475,7 @@ let injConcl = injClause None false None let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (Loc.tag id))) let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = clause.evd in let env = Proofview.Goal.env gl in match find_positions env sigma ~no_discr:false t1 t2 with @@ -1493,7 +1486,7 @@ let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = | Inr posns -> inject_at_positions env sigma true u clause posns (ntac (clenv_value clause)) - end } + end let dEqThen with_evars ntac = function | None -> onNegatedEquality with_evars (decompEqThen (ntac None)) @@ -1504,10 +1497,10 @@ let dEq with_evars = (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)) let intro_decomp_eq tac data (c, t) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let cl = pf_apply make_clenv_binding gl (c, t) NoBindings in decompEqThen (fun _ -> tac) data cl - end } + end let _ = declare_intro_decomp_eq intro_decomp_eq @@ -1558,7 +1551,6 @@ let decomp_tuple_term env sigma c t = in decomprec (mkRel 1) c t let subst_tuple_term env sigma dep_pair1 dep_pair2 b = - let sigma = Sigma.to_evar_map sigma in let typ = get_type_of env sigma dep_pair1 in (* We find all possible decompositions *) let decomps1 = decomp_tuple_term env sigma dep_pair1 typ in @@ -1583,7 +1575,7 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* Retype to get universes right *) let sigma, expected_goal_ty = Typing.type_of env sigma expected_goal in let sigma, _ = Typing.type_of env sigma body in - Sigma.Unsafe.of_pair ((body, expected_goal), sigma) + (sigma, (body, expected_goal)) (* Like "replace" but decompose dependent equalities *) (* i.e. if equality is "exists t v = exists u w", and goal is "phi(t,u)", *) @@ -1591,42 +1583,38 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* on for further iterated sigma-tuples *) let cutSubstInConcl l2r eqn = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_concl gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in - let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in - let tac = - tclTHENFIRST + let (sigma, (typ, expected)) = subst_tuple_term env sigma e1 e2 typ in + tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (tclTHENFIRST (tclTHENLIST [ (change_concl typ); (* Put in pattern form *) (replace_core onConcl l2r eqn) ]) - (change_concl expected) (* Put in normalized form *) - in - Sigma (tac, sigma, p) - end } + (change_concl expected)) (* Put in normalized form *) + end let cutSubstInHyp l2r eqn id = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_get_hyp_typ id gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in - let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in - let tac = - tclTHENFIRST + let (sigma, (typ, expected)) = subst_tuple_term env sigma e1 e2 typ in + tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (tclTHENFIRST (tclTHENLIST [ (change_in_hyp None (make_change_arg typ) (id,InHypTypeOnly)); (replace_core (onHyp id) l2r eqn) ]) - (change_in_hyp None (make_change_arg expected) (id,InHypTypeOnly)) - in - Sigma (tac, sigma, p) - end } + (change_in_hyp None (make_change_arg expected) (id,InHypTypeOnly))) + end let try_rewrite tac = Proofview.tclORELSE tac begin function (e, info) -> match e with @@ -1648,11 +1636,11 @@ let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id) let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None let substClause l2r c cls = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let eq = pf_apply get_type_of gl c in tclTHENS (cutSubstClause l2r eq cls) [Proofview.tclUNIT (); exact_no_check c] - end } + end let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls) let rewriteInHyp l2r c id = rewriteClause l2r c (Some id) @@ -1713,7 +1701,7 @@ let is_eq_x gl x d = erase hyp and x; proceed by generalizing all dep hyps *) let subst_one dep_proof_ok x (hyp,rhs,dir) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in @@ -1742,13 +1730,13 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = else [Proofview.tclUNIT ()]) @ [tclTRY (clear [x; hyp])]) - end } + end (* Look for an hypothesis hyp of the form "x=rhs" or "rhs=x", rewrite it everywhere, and erase hyp and x; proceed by generalizing all dep hyps *) let subst_one_var dep_proof_ok x = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let gl = Proofview.Goal.assume gl in let decl = pf_get_hyp x gl in (* If x has a body, simply replace x with body and clear x *) @@ -1765,7 +1753,7 @@ let subst_one_var dep_proof_ok x = str".") with FoundHyp res -> res in subst_one dep_proof_ok x res - end } + end let subst_gen dep_proof_ok ids = tclMAP (subst_one_var dep_proof_ok) ids @@ -1818,7 +1806,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = (* Second step: treat equations *) let process hyp = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let gl = Proofview.Goal.assume gl in let sigma = project gl in let env = Proofview.Goal.env gl in @@ -1834,19 +1822,19 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = subst_one flags.rewrite_dependent_proof y' (hyp,x,false) | _ -> Proofview.tclUNIT () - end } + end in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let ids = find_equations gl in tclMAP process ids - end } + end else (* Old implementation, not able to manage configurations like a=b, a=t, or situations like "a = S b, b = S a", or also accidentally unfolding let-ins *) - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in let find_eq_data_decompose = find_eq_data_decompose gl in let test (_,c) = @@ -1865,7 +1853,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let ids = List.map_filter test hyps in let ids = List.uniquize ids in subst_gen flags.rewrite_dependent_proof ids - end } + end (* Rewrite the first assumption for which a condition holds and gives the direction of the rewrite *) @@ -1902,11 +1890,10 @@ let rewrite_assumption_cond cond_eq_term cl = with | Failure _ | UserError _ -> arec rest gl end in - Proofview.Goal.enter { enter = begin fun gl -> - let gl = Proofview.Goal.lift gl Sigma.Unsafe.le in + Proofview.Goal.enter begin fun gl -> let hyps = Proofview.Goal.hyps gl in arec hyps gl - end } + end (* Generalize "subst x" to substitution of subterm appearing as an equation in the context, but not clearing the hypothesis *) diff --git a/tactics/hints.ml b/tactics/hints.ml index 70e62eaba..773abb9f0 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -22,7 +22,6 @@ open Namegen open Libnames open Smartlocate open Misctypes -open Tactypes open Termops open Inductiveops open Typing @@ -34,7 +33,6 @@ open Pfedit open Tacred open Printer open Vernacexpr -open Sigma.Notations module NamedDecl = Context.Named.Declaration @@ -1363,11 +1361,7 @@ let add_hint_lemmas env sigma eapply lems hint_db = Hint_db.add_list env sigma hintlist' hint_db let make_local_hint_db env sigma ts eapply lems = - let map c = - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (c, sigma, _) = c.delayed env sigma in - (Sigma.to_evar_map sigma, c) - in + let map c = c env sigma in let lems = List.map map lems in let sign = EConstr.named_context env in let ts = match ts with diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 9110830aa..a1d986544 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -120,11 +120,11 @@ val match_with_equation: (** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *) -val find_eq_data_decompose : ('a, 'r) Proofview.Goal.t -> constr -> +val find_eq_data_decompose : 'a Proofview.Goal.t -> constr -> coq_eq_data * EInstance.t * (types * constr * constr) (** Idem but fails with an error message instead of PatternMatchingFailure *) -val find_this_eq_data_decompose : ('a, 'r) Proofview.Goal.t -> constr -> +val find_this_eq_data_decompose : 'a Proofview.Goal.t -> constr -> coq_eq_data * EInstance.t * (types * constr * constr) (** A variant that returns more informative structure on the equality found *) @@ -145,7 +145,7 @@ val is_matching_sigma : evar_map -> constr -> bool val match_eqdec : evar_map -> constr -> bool * Globnames.global_reference * constr * constr * constr (** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *) -val dest_nf_eq : ('a, 'r) Proofview.Goal.t -> constr -> (constr * constr * constr) +val dest_nf_eq : 'a Proofview.Goal.t -> constr -> (constr * constr * constr) (** Match a negation *) val is_matching_not : evar_map -> constr -> bool diff --git a/tactics/inv.ml b/tactics/inv.ml index b951e7ceb..ec038f638 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -25,7 +25,6 @@ open Tactics open Elim open Equality open Misctypes -open Sigma.Notations open Proofview.Notations module NamedDecl = Context.Named.Declaration @@ -272,14 +271,14 @@ Nota: with Inversion_clear, only four useless hypotheses let generalizeRewriteIntros as_mode tac depids id = Proofview.tclENV >>= fun env -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let dids = dependent_hyps env id depids gl in let reintros = if as_mode then intros_replacing else intros_possibly_replacing in (tclTHENLIST [bring_hyps dids; tac; (* may actually fail to replace if dependent in a previous eq *) reintros (ids_of_named_context dids)]) - end } + end let error_too_many_names pats = let loc = Loc.merge_opt (fst (List.hd pats)) (fst (List.last pats)) in @@ -287,7 +286,7 @@ let error_too_many_names pats = tclZEROMSG ?loc ( str "Unexpected " ++ str (String.plural (List.length pats) "introduction pattern") ++ - str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (EConstr.Unsafe.to_constr (fst (run_delayed env Evd.empty c))))) pats ++ + str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (EConstr.Unsafe.to_constr (snd (c env Evd.empty))))) pats ++ str ".") let get_names (allow_conj,issimple) (loc, pat as x) = match pat with @@ -341,7 +340,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = (if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC)) in let substHypIfVariable tac id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in (** We only look at the type of hypothesis "id" *) let hyp = pf_nf_evar gl (pf_get_hyp_typ id (Proofview.Goal.assume gl)) in @@ -350,7 +349,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = | Var id1, _ -> generalizeRewriteIntros as_mode (subst_hyp true id) depids id1 | _, Var id2 -> generalizeRewriteIntros as_mode (subst_hyp false id) depids id2 | _ -> tac id - end } + end in let deq_trailer id clear_flag _ neqns = assert (clear_flag == None); @@ -377,7 +376,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = id let nLastDecls i tac = - Proofview.Goal.enter { enter = begin fun gl -> tac (nLastDecls gl i) end } + Proofview.Goal.enter begin fun gl -> tac (nLastDecls gl i) end (* Introduction of the equations on arguments othin: discriminates Simple Inversion, Inversion and Inversion_clear @@ -385,7 +384,7 @@ let nLastDecls i tac = Some thin: the equations are rewritten, and cleared if thin is true *) let rewrite_equations as_mode othin neqns names ba = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (depids,nodepids) = split_dep_and_nodep ba.Tacticals.assums gl in let first_eq = ref MoveLast in let avoid = if as_mode then List.map NamedDecl.get_id nodepids else [] in @@ -418,7 +417,7 @@ let rewrite_equations as_mode othin neqns names ba = [tclDO neqns intro; bring_hyps nodepids; clear (ids_of_named_context nodepids)]) - end } + end let interp_inversion_kind = function | SimpleInversion -> None @@ -435,9 +434,8 @@ let rewrite_equations_tac as_mode othin id neqns names ba = tac let raw_inversion inv_kind id status names = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in let c = mkVar id in @@ -462,11 +460,11 @@ let raw_inversion inv_kind id status names = in let refined id = let prf = mkApp (mkVar id, args) in - Refine.refine { run = fun h -> Sigma (prf, h, Sigma.refl) } + Refine.refine (fun h -> (h, prf)) in let neqns = List.length realargs in let as_mode = names != None in - let tac = + tclTHEN (Proofview.Unsafe.tclEVARS sigma) (tclTHENS (assert_before Anonymous cut_concl) [case_tac names @@ -474,9 +472,7 @@ let raw_inversion inv_kind id status names = (rewrite_equations_tac as_mode inv_kind id neqns)) (Some elim_predicate) ind (c,t); onLastHypId (fun id -> tclTHEN (refined id) reflexivity)]) - in - Sigma.Unsafe.of_pair (tac, sigma) - end } + end (* Error messages of the inversion tactics *) let wrap_inv_error id = function (e, info) -> match e with @@ -516,13 +512,13 @@ let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id) * back to their places in the hyp-list. *) let invIn k names ids id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let hyps = List.map (fun id -> pf_get_hyp id gl) ids in let concl = Proofview.Goal.concl gl in let sigma = project gl in let nb_prod_init = nb_prod sigma concl in let intros_replace_ids = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = pf_concl gl in let sigma = project gl in let nb_of_new_hyp = @@ -532,7 +528,7 @@ let invIn k names ids id = intros_replacing ids else tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids) - end } + end in Proofview.tclORELSE (tclTHENLIST @@ -540,7 +536,7 @@ let invIn k names ids id = inversion k NoDep names id; intros_replace_ids]) (wrap_inv_error id) - end } + end let invIn_gen k names idl = try_intros_until (invIn k names idl) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 83f3da30a..87d815fc8 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -27,7 +27,6 @@ open Declare open Tacticals.New open Tactics open Decl_kinds -open Proofview.Notations open Context.Named.Declaration module NamedDecl = Context.Named.Declaration @@ -261,7 +260,7 @@ let add_inversion_lemma_exn na com comsort bool tac = (* ================================= *) let lemInv id c = - Proofview.Goal.enter { enter = begin fun gls -> + Proofview.Goal.enter begin fun gls -> try let clause = mk_clenv_from_env (pf_env gls) (project gls) None (c, pf_unsafe_type_of gls c) in let clause = clenv_constrain_last_binding (EConstr.mkVar id) clause in @@ -274,12 +273,12 @@ let lemInv id c = user_err ~hdr:"LemInv" (str "Cannot refine current goal with the lemma " ++ pr_leconstr_env (pf_env gls) (project gls) c) - end } + end let lemInv_gen id c = try_intros_until (fun id -> lemInv id c) id let lemInvIn id c ids = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let hyps = List.map (fun id -> pf_get_hyp id gl) ids in let intros_replace_ids = let concl = Proofview.Goal.concl gl in @@ -292,7 +291,7 @@ let lemInvIn id c ids = in ((tclTHEN (tclTHEN (bring_hyps hyps) (lemInv id c)) (intros_replace_ids))) - end } + end let lemInvIn_gen id c l = try_intros_until (fun id -> lemInvIn id c l) id diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index a7eadc3c3..aa574e41c 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -17,7 +17,6 @@ open Declarations open Tacmach open Clenv open Tactypes -open Sigma.Notations module NamedDecl = Context.Named.Declaration @@ -511,12 +510,12 @@ module New = struct Proofview.Unsafe.tclEVARS sigma <*> tac >>= check_evars_if let tclDELAYEDWITHHOLES check x tac = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let Sigma (x, sigma, _) = x.delayed env sigma in - tclWITHHOLES check (tac x) (Sigma.to_evar_map sigma) - end } + let (sigma, x) = x env sigma in + tclWITHHOLES check (tac x) sigma + end let tclTIMEOUT n t = Proofview.tclOR @@ -547,66 +546,66 @@ module New = struct mkVar (nthHypId m gl) let onNthHypId m tac = - Proofview.Goal.enter { enter = begin fun gl -> tac (nthHypId m gl) end } + Proofview.Goal.enter begin fun gl -> tac (nthHypId m gl) end let onNthHyp m tac = - Proofview.Goal.enter { enter = begin fun gl -> tac (nthHyp m gl) end } + Proofview.Goal.enter begin fun gl -> tac (nthHyp m gl) end let onLastHypId = onNthHypId 1 let onLastHyp = onNthHyp 1 let onNthDecl m tac = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> Proofview.tclUNIT (nthDecl m gl) >>= tac - end } + end let onLastDecl = onNthDecl 1 let ifOnHyp pred tac1 tac2 id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let typ = Tacmach.New.pf_get_hyp_typ id gl in if pred (id,typ) then tac1 id else tac2 id - end } + end - let onHyps find tac = Proofview.Goal.enter { enter = begin fun gl -> tac (find.enter gl) end } + let onHyps find tac = Proofview.Goal.enter begin fun gl -> tac (find gl) end let afterHyp id tac = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in let rem, _ = List.split_when (NamedDecl.get_id %> Id.equal id) hyps in tac rem - end } + end let fullGoal gl = let hyps = Tacmach.New.pf_ids_of_hyps gl in None :: List.map Option.make hyps let tryAllHyps tac = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let hyps = Tacmach.New.pf_ids_of_hyps gl in tclFIRST_PROGRESS_ON tac hyps - end } + end let tryAllHypsAndConcl tac = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> tclFIRST_PROGRESS_ON tac (fullGoal gl) - end } + end let onClause tac cl = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let hyps = Tacmach.New.pf_ids_of_hyps gl in tclMAP tac (Locusops.simple_clause_of (fun () -> hyps) cl) - end } + end (* Find the right elimination suffix corresponding to the sort of the goal *) (* c should be of type A1->.. An->B with B an inductive definition *) let general_elim_then_using mk_elim isrec allnames tac predicate ind (c, t) = - Proofview.Goal.enter { enter = begin fun gl -> - let sigma, elim = (mk_elim ind).enter gl in + Proofview.Goal.enter begin fun gl -> + let sigma, elim = mk_elim ind gl in let ind = on_snd (fun u -> EInstance.kind sigma u) ind in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (Proofview.Goal.enter { enter = begin fun gl -> + (Proofview.Goal.enter begin fun gl -> let indclause = mk_clenv_from gl (c, t) in (* applying elimination_scheme just a little modified *) let elimclause = mk_clenv_from gl (elim,Tacmach.New.pf_unsafe_type_of gl elim) in @@ -655,7 +654,7 @@ module New = struct Proofview.tclTHEN (Clenvtac.clenv_refine false clenv') (Proofview.tclEXTEND [] tclIDTAC branchtacs) - end }) end } + end) end let elimination_sort_of_goal gl = (** Retyping will expand evars anyway. *) @@ -673,29 +672,29 @@ module New = struct (* computing the case/elim combinators *) - let gl_make_elim ind = { enter = begin fun gl -> + let gl_make_elim ind = begin fun gl -> let gr = Indrec.lookup_eliminator (fst ind) (elimination_sort_of_goal gl) in let (sigma, c) = pf_apply Evd.fresh_global gl gr in (sigma, EConstr.of_constr c) - end } + end - let gl_make_case_dep (ind, u) = { enter = begin fun gl -> - let sigma = Sigma.Unsafe.of_evar_map (project gl) in + let gl_make_case_dep (ind, u) = begin fun gl -> + let sigma = project gl in let u = EInstance.kind (project gl) u in - let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma (ind, u) true + let (sigma, r) = Indrec.build_case_analysis_scheme (pf_env gl) sigma (ind, u) true (elimination_sort_of_goal gl) in - (Sigma.to_evar_map sigma, EConstr.of_constr r) - end } + (sigma, EConstr.of_constr r) + end - let gl_make_case_nodep (ind, u) = { enter = begin fun gl -> - let sigma = Sigma.Unsafe.of_evar_map (project gl) in - let u = EInstance.kind (project gl) u in - let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma (ind, u) false + let gl_make_case_nodep (ind, u) = begin fun gl -> + let sigma = project gl in + let u = EInstance.kind sigma u in + let (sigma, r) = Indrec.build_case_analysis_scheme (pf_env gl) sigma (ind, u) false (elimination_sort_of_goal gl) in - (Sigma.to_evar_map sigma, EConstr.of_constr r) - end } + (sigma, EConstr.of_constr r) + end let make_elim_branch_assumptions ba hyps = let assums = @@ -704,19 +703,19 @@ module New = struct { ba = ba; assums = assums } let elim_on_ba tac ba = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let branches = make_elim_branch_assumptions ba (Proofview.Goal.hyps gl) in tac branches - end } + end let case_on_ba tac ba = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let branches = make_elim_branch_assumptions ba (Proofview.Goal.hyps gl) in tac branches - end } + end let elimination_then tac c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (ind,t) = pf_reduce_to_quantified_ind gl (pf_unsafe_type_of gl c) in let isrec,mkelim = match (Global.lookup_mind (fst (fst ind))).mind_record with @@ -724,7 +723,7 @@ module New = struct | Some _ -> false,gl_make_case_dep in general_elim_then_using mkelim isrec None tac None ind (c, t) - end } + end let case_then_using = general_elim_then_using gl_make_case_dep false diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 96270f748..9603212de 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -225,7 +225,7 @@ module New : sig val tclTIMEOUT : int -> unit tactic -> unit tactic val tclTIME : string option -> 'a tactic -> 'a tactic - val nLastDecls : ('a, 'r) Proofview.Goal.t -> int -> named_context + val nLastDecls : 'a Proofview.Goal.t -> int -> named_context val ifOnHyp : (identifier * types -> bool) -> (identifier -> unit Proofview.tactic) -> (identifier -> unit Proofview.tactic) -> @@ -236,7 +236,7 @@ module New : sig val onLastHyp : (constr -> unit tactic) -> unit tactic val onLastDecl : (named_declaration -> unit tactic) -> unit tactic - val onHyps : ([ `LZ ], named_context) Proofview.Goal.enter -> + val onHyps : ([ `LZ ] Proofview.Goal.t -> named_context) -> (named_context -> unit tactic) -> unit tactic val afterHyp : Id.t -> (named_context -> unit tactic) -> unit tactic @@ -244,9 +244,9 @@ module New : sig val tryAllHypsAndConcl : (identifier option -> unit tactic) -> unit tactic val onClause : (identifier option -> unit tactic) -> clause -> unit tactic - val elimination_sort_of_goal : ('a, 'r) Proofview.Goal.t -> sorts_family - val elimination_sort_of_hyp : Id.t -> ('a, 'r) Proofview.Goal.t -> sorts_family - val elimination_sort_of_clause : Id.t option -> ('a, 'r) Proofview.Goal.t -> sorts_family + val elimination_sort_of_goal : 'a Proofview.Goal.t -> sorts_family + val elimination_sort_of_hyp : Id.t -> 'a Proofview.Goal.t -> sorts_family + val elimination_sort_of_clause : Id.t option -> 'a Proofview.Goal.t -> sorts_family val elimination_then : (branch_args -> unit Proofview.tactic) -> diff --git a/tactics/tactics.ml b/tactics/tactics.ml index a93a86d3a..b553f316c 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -43,9 +43,7 @@ open Unification open Locus open Locusops open Misctypes -open Tactypes open Proofview.Notations -open Sigma.Notations open Context.Named.Declaration module RelDecl = Context.Rel.Declaration @@ -55,7 +53,7 @@ let inj_with_occurrences e = (AllOccurrences,e) let typ_of env sigma c = let open Retyping in - try get_type_of ~lax:true env (Sigma.to_evar_map sigma) c + try get_type_of ~lax:true env sigma c with RetypeError e -> user_err (print_retype_error e) @@ -165,18 +163,18 @@ let _ = (** This tactic creates a partial proof realizing the introduction rule, but does not check anything. *) let unsafe_intro env store decl b = - Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true begin fun sigma -> let ctx = named_context_val env in let nctx = push_named_context_val decl ctx in let inst = List.map (NamedDecl.get_id %> mkVar) (named_context env) in let ninst = mkRel 1 :: inst in let nb = subst1 (mkVar (NamedDecl.get_id decl)) b in - let Sigma (ev, sigma, p) = new_evar_instance nctx sigma nb ~principal:true ~store ninst in - Sigma (mkNamedLambda_or_LetIn decl ev, sigma, p) - end } + let (sigma, ev) = new_evar_instance nctx sigma nb ~principal:true ~store ninst in + (sigma, mkNamedLambda_or_LetIn decl ev) + end let introduction ?(check=true) id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in @@ -192,49 +190,48 @@ let introduction ?(check=true) id = | Prod (_, t, b) -> unsafe_intro env store (LocalAssum (id, t)) b | LetIn (_, c, t, b) -> unsafe_intro env store (LocalDef (id, c, t)) b | _ -> raise (RefinerError IntroNeedsProduct) - end } + end let refine = Tacmach.refine let error msg = CErrors.user_err Pp.(str msg) let convert_concl ?(check=true) ty k = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let conclty = Proofview.Goal.concl gl in - Refine.refine ~unsafe:true { run = begin fun sigma -> - let Sigma ((), sigma, p) = + Refine.refine ~unsafe:true begin fun sigma -> + let sigma = if check then begin - let sigma = Sigma.to_evar_map sigma in ignore (Typing.unsafe_type_of env sigma ty); let sigma,b = Reductionops.infer_conv env sigma ty conclty in if not b then error "Not convertible."; - Sigma.Unsafe.of_pair ((), sigma) - end else Sigma.here () sigma in - let Sigma (x, sigma, q) = Evarutil.new_evar env sigma ~principal:true ~store ty in + sigma + end else sigma in + let (sigma, x) = Evarutil.new_evar env sigma ~principal:true ~store ty in let ans = if k == DEFAULTcast then x else mkCast(x,k,conclty) in - Sigma (ans, sigma, p +> q) - end } - end } + (sigma, ans) + end + end let convert_hyp ?(check=true) d = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ty = Proofview.Goal.concl gl in let store = Proofview.Goal.extra gl in let sign = convert_hyp check (named_context_val env) sigma d in let env = reset_with_named_context sign env in - Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty - end } - end } + end + end let convert_concl_no_check = convert_concl ~check:false let convert_hyp_no_check = convert_hyp ~check:false let convert_gen pb x y = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> try let sigma, b = Tacmach.New.pf_apply (Reductionops.infer_conv ~pb) gl x y in if b then Proofview.Unsafe.tclEVARS sigma @@ -242,7 +239,7 @@ let convert_gen pb x y = with (* Reduction.NotConvertible *) _ -> (** FIXME: Sometimes an anomaly is raised from conversion *) Tacticals.New.tclFAIL 0 (str "Not convertible") -end } +end let convert x y = convert_gen Reduction.CONV x y let convert_leq x y = convert_gen Reduction.CUMUL x y @@ -282,7 +279,7 @@ let error_replacing_dependency env sigma id err = let clear_gen fail = function | [] -> Proofview.tclUNIT () | ids -> - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let ids = List.fold_right Id.Set.add ids Id.Set.empty in (** clear_hyps_in_evi does not require nf terms *) let gl = Proofview.Goal.assume gl in @@ -295,11 +292,11 @@ let clear_gen fail = function with Evarutil.ClearDependencyError (id,err) -> fail env sigma id err in let env = reset_with_named_context hyps env in - let tac = Refine.refine ~unsafe:true { run = fun sigma -> + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) + (Refine.refine ~unsafe:true begin fun sigma -> Evarutil.new_evar env sigma ~principal:true concl - } in - Sigma.Unsafe.of_pair (tac, !evdref) - end } + end) + end let clear ids = clear_gen error_clear_dependency ids let clear_for_replacing ids = clear_gen error_replacing_dependency ids @@ -318,7 +315,7 @@ let apply_clear_request clear_flag dft c = (* Moving hypotheses *) let move_hyp id dest = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ty = Proofview.Goal.concl gl in @@ -326,10 +323,10 @@ let move_hyp id dest = let sign = named_context_val env in let sign' = move_hyp_in_named_context sigma id dest sign in let env = reset_with_named_context sign' env in - Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty - end } - end } + end + end (* Renaming hypotheses *) let rename_hyp repl = @@ -348,7 +345,7 @@ let rename_hyp repl = match dom with | None -> Tacticals.New.tclZEROMSG (str "Not a one-to-one name mapping") | Some (src, dst) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let gl = Proofview.Goal.assume gl in let hyps = Proofview.Goal.hyps gl in let concl = Proofview.Goal.concl gl in @@ -380,10 +377,10 @@ let rename_hyp repl = let nconcl = subst concl in let nctx = val_of_named_context nhyps in let instance = List.map (NamedDecl.get_id %> mkVar) hyps in - Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true begin fun sigma -> Evarutil.new_evar_instance nctx sigma nconcl ~principal:true ~store instance - end } - end } + end + end (**************************************************************) (* Fresh names *) @@ -447,7 +444,7 @@ let find_name mayrepl decl naming gl = match naming with let assert_before_then_gen b naming t tac = let open Context.Rel.Declaration in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let id = find_name b (LocalAssum (Anonymous,t)) naming gl in Tacticals.New.tclTHENLAST (Proofview.V82.tactic @@ -456,7 +453,7 @@ let assert_before_then_gen b naming t tac = with Evarutil.ClearDependencyError (id,err) -> error_replacing_dependency (pf_env gl) (project gl) id err)) (tac id) - end } + end let assert_before_gen b naming t = assert_before_then_gen b naming t (fun _ -> Proofview.tclUNIT ()) @@ -466,7 +463,7 @@ let assert_before_replacing id = assert_before_gen true (NamingMustBe (Loc.tag i let assert_after_then_gen b naming t tac = let open Context.Rel.Declaration in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let id = find_name b (LocalAssum (Anonymous,t)) naming gl in Tacticals.New.tclTHENFIRST (Proofview.V82.tactic @@ -475,7 +472,7 @@ let assert_after_then_gen b naming t tac = with Evarutil.ClearDependencyError (id,err) -> error_replacing_dependency (pf_env gl) (project gl) id err)) (tac id) - end } + end let assert_after_gen b naming t = assert_after_then_gen b naming t (fun _ -> (Proofview.tclUNIT ())) @@ -487,13 +484,12 @@ let assert_after_replacing id = assert_after_gen true (NamingMustBe (Loc.tag id) (* Fixpoints and CoFixpoints *) (**************************************************************) -let rec mk_holes : type r s. _ -> r Sigma.t -> (s, r) Sigma.le -> _ -> (_, s) Sigma.sigma = -fun env sigma p -> function -| [] -> Sigma ([], sigma, p) +let rec mk_holes env sigma = function +| [] -> (sigma, []) | arg :: rem -> - let Sigma (arg, sigma, q) = Evarutil.new_evar env sigma arg in - let Sigma (rem, sigma, r) = mk_holes env sigma (p +> q) rem in - Sigma (arg :: rem, sigma, r) + let (sigma, arg) = Evarutil.new_evar env sigma arg in + let (sigma, rem) = mk_holes env sigma rem in + (sigma, arg :: rem) let rec check_mutind env sigma k cl = match EConstr.kind sigma (strip_outer_cast sigma cl) with | Prod (na, c1, b) -> @@ -511,7 +507,7 @@ let rec check_mutind env sigma k cl = match EConstr.kind sigma (strip_outer_cast | _ -> error "Not enough products." (* Refine as a fixpoint *) -let mutual_fix f n rest j = Proofview.Goal.enter { enter = begin fun gl -> +let mutual_fix f n rest j = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in @@ -531,8 +527,8 @@ let mutual_fix f n rest j = Proofview.Goal.enter { enter = begin fun gl -> mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in - Refine.refine { run = begin fun sigma -> - let Sigma (evs, sigma, p) = mk_holes nenv sigma Sigma.refl (List.map pi3 all) in + Refine.refine begin fun sigma -> + let (sigma, evs) = mk_holes nenv sigma (List.map pi3 all) 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 @@ -540,17 +536,17 @@ let mutual_fix f n rest j = Proofview.Goal.enter { enter = begin fun gl -> let typarray = Array.of_list (List.map pi3 all) in let bodies = Array.of_list evs in let oterm = mkFix ((indxs,0),(funnames,typarray,bodies)) in - Sigma (oterm, sigma, p) - end } -end } + (sigma, oterm) + end +end let fix ido n = match ido with | None -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let name = Pfedit.get_current_proof_name () in let id = new_fresh_id [] name gl in mutual_fix id n [] 0 - end } + end | Some id -> mutual_fix id n [] 0 @@ -567,7 +563,7 @@ let rec check_is_mutcoind env sigma cl = error "All methods must construct elements in coinductive types." (* Refine as a cofixpoint *) -let mutual_cofix f others j = Proofview.Goal.enter { enter = begin fun gl -> +let mutual_cofix f others j = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in @@ -583,25 +579,25 @@ let mutual_cofix f others j = Proofview.Goal.enter { enter = begin fun gl -> mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in - Refine.refine { run = begin fun sigma -> + Refine.refine begin fun sigma -> let (ids, types) = List.split all in - let Sigma (evs, sigma, p) = mk_holes nenv sigma Sigma.refl types in + let (sigma, evs) = mk_holes nenv sigma types 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 = mkCoFix (0, (funnames, typarray, bodies)) in - Sigma (oterm, sigma, p) - end } -end } + (sigma, oterm) + end +end let cofix ido = match ido with | None -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let name = Pfedit.get_current_proof_name () in let id = new_fresh_id [] name gl in mutual_cofix id [] 0 - end } + end | Some id -> mutual_cofix id [] 0 @@ -693,14 +689,14 @@ let bind_red_expr_occurrences occs nbcl redexp = certain hypothesis *) let reduct_in_concl (redfun,sty) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> convert_concl_no_check (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl)) sty - end } + end let reduct_in_hyp ?(check=false) redfun (id,where) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> convert_hyp ~check (pf_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl) - end } + end let revert_cast (redfun,kind as r) = if kind == DEFAULTcast then (redfun,REVERTcast) else r @@ -714,30 +710,32 @@ let reduct_option ?(check=false) redfun = function let pf_e_reduce_decl redfun where decl gl = let open Context.Named.Declaration in let sigma = Proofview.Goal.sigma gl in - let redfun sigma c = redfun.e_redfun (Tacmach.New.pf_env gl) sigma c in + let redfun sigma c = redfun (Tacmach.New.pf_env gl) sigma c in match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then user_err (pr_id id ++ str " has no value."); - let Sigma (ty', sigma, p) = redfun sigma ty in - Sigma (LocalAssum (id, ty'), sigma, p) + let (sigma, ty') = redfun sigma ty in + (sigma, LocalAssum (id, ty')) | LocalDef (id,b,ty) -> - let Sigma (b', sigma, p) = if where != InHypTypeOnly then redfun sigma b else Sigma.here b sigma in - let Sigma (ty', sigma, q) = if where != InHypValueOnly then redfun sigma ty else Sigma.here ty sigma in - Sigma (LocalDef (id, b', ty'), sigma, p +> q) + let (sigma, b') = if where != InHypTypeOnly then redfun sigma b else (sigma, b) in + let (sigma, ty') = if where != InHypValueOnly then redfun sigma ty else (sigma, ty) in + (sigma, LocalDef (id, b', ty')) let e_reduct_in_concl ~check (redfun, sty) = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let Sigma (c', sigma, p) = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in - Sigma (convert_concl ~check c' sty, sigma, p) - end } + let (sigma, c') = redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (convert_concl ~check c' sty) + end let e_reduct_in_hyp ?(check=false) redfun (id, where) = - Proofview.Goal.s_enter { s_enter = begin fun gl -> - let Sigma (decl', sigma, p) = pf_e_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl in - Sigma (convert_hyp ~check decl', sigma, p) - end } + Proofview.Goal.enter begin fun gl -> + let (sigma, decl') = pf_e_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (convert_hyp ~check decl') + end let e_reduct_option ?(check=false) redfun = function | Some id -> e_reduct_in_hyp ~check (fst redfun) id @@ -747,11 +745,12 @@ let e_reduct_option ?(check=false) redfun = function from conversions. *) let e_change_in_concl (redfun,sty) = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let Sigma (c, sigma, p) = redfun.e_redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.concl gl) in - Sigma (convert_concl_no_check c sty, sigma, p) - end } + let (sigma, c) = redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.concl gl) in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (convert_concl_no_check c sty) + end let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigma = let open Context.Named.Declaration in @@ -759,29 +758,29 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigm | LocalAssum (id,ty) -> if where == InHypValueOnly then user_err (pr_id id ++ str " has no value."); - let Sigma (ty', sigma, p) = (redfun false).e_redfun env sigma ty in - Sigma (LocalAssum (id, ty'), sigma, p) + let (sigma, ty') = redfun false env sigma ty in + (sigma, LocalAssum (id, ty')) | LocalDef (id,b,ty) -> - let Sigma (b', sigma, p) = - if where != InHypTypeOnly then (redfun true).e_redfun env sigma b else Sigma.here b sigma + let (sigma, b') = + if where != InHypTypeOnly then redfun true env sigma b else (sigma, b) in - let Sigma (ty', sigma, q) = - if where != InHypValueOnly then (redfun false).e_redfun env sigma ty else Sigma.here ty sigma + let (sigma, ty') = + if where != InHypValueOnly then redfun false env sigma ty else (sigma, ty) in - Sigma (LocalDef (id,b',ty'), sigma, p +> q) + (sigma, LocalDef (id,b',ty')) let e_change_in_hyp redfun (id,where) = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let hyp = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in - let Sigma (c, sigma, p) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in - Sigma (convert_hyp c, sigma, p) - end } + let (sigma, c) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (convert_hyp c) + end -type change_arg = Pattern.patvar_map -> EConstr.constr Sigma.run +type change_arg = Pattern.patvar_map -> evar_map -> evar_map * EConstr.constr -let make_change_arg c pats = - { run = fun sigma -> Sigma.here (replace_vars (Id.Map.bindings pats) c) sigma } +let make_change_arg c pats sigma = (sigma, replace_vars (Id.Map.bindings pats) c) let check_types env sigma mayneedglobalcheck deep newc origc = let t1 = Retyping.get_type_of env sigma newc in @@ -805,33 +804,30 @@ let check_types env sigma mayneedglobalcheck deep newc origc = else sigma (* Now we introduce different instances of the previous tacticals *) -let change_and_check cv_pb mayneedglobalcheck deep t = { e_redfun = begin fun env sigma c -> - let Sigma (t', sigma, p) = t.run sigma in - let sigma = Sigma.to_evar_map sigma in +let change_and_check cv_pb mayneedglobalcheck deep t env sigma c = + let (sigma, t') = t sigma in let sigma = check_types env sigma mayneedglobalcheck deep t' c in let sigma, b = infer_conv ~pb:cv_pb env sigma t' c in if not b then user_err ~hdr:"convert-check-hyp" (str "Not convertible."); - Sigma.Unsafe.of_pair (t', sigma) -end } + (sigma, t') (* Use cumulativity only if changing the conclusion not a subterm *) -let change_on_subterm cv_pb deep t where = { e_redfun = begin fun env sigma c -> +let change_on_subterm cv_pb deep t where env sigma c = let mayneedglobalcheck = ref false in - let Sigma (c, sigma, p) = match where with - | None -> (change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty)).e_redfun env sigma c + let (sigma, c) = match where with + | None -> change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty) env sigma c | Some occl -> - (e_contextually false occl + e_contextually false occl (fun subst -> - change_and_check Reduction.CONV mayneedglobalcheck true (t subst))).e_redfun + change_and_check Reduction.CONV mayneedglobalcheck true (t subst)) env sigma c in if !mayneedglobalcheck then begin - try ignore (Typing.unsafe_type_of env (Sigma.to_evar_map sigma) c) + try ignore (Typing.unsafe_type_of env sigma c) with e when catchable_exception e -> error "Replacement would lead to an ill-typed term." end; - Sigma (c, sigma, p) -end } + (sigma, c) let change_in_concl occl t = e_change_in_concl ((change_on_subterm Reduction.CUMUL false t occl),DEFAULTcast) @@ -844,7 +840,7 @@ let change_option occl t = function | None -> change_in_concl occl t let change chg c cls = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let cls = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in Tacticals.New.tclMAP (function | OnHyp (id,occs,where) -> @@ -852,7 +848,7 @@ let change chg c cls = | OnConcl occs -> change_option (bind_change_occurrences occs chg) c None) cls - end } + end let change_concl t = change_in_concl None (make_change_arg t) @@ -893,14 +889,14 @@ let reduce redexp cl = Pp.(hov 2 (Pputils.pr_red_expr pr str redexp)) in Proofview.Trace.name_tactic trace begin - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let cl' = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in let redexps = reduction_clause redexp cl' in let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in Tacticals.New.tclMAP (fun (where,redexp) -> e_reduct_option ~check (Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp) where) redexps - end } + end end (* Unfolding occurrences of a constant *) @@ -936,7 +932,7 @@ let build_intro_tac id dest tac = match dest with let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = let open Context.Rel.Declaration in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in match EConstr.kind sigma concl with @@ -962,7 +958,7 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = Tacticals.New.tclZEROMSG (str "No product even after head-reduction.") | e -> Proofview.tclZERO ~info e end - end } + end let intro_gen n m f d = intro_then_gen n m f d (fun _ -> Proofview.tclUNIT ()) let intro_mustbe_force id = intro_gen (NamingMustBe (Loc.tag id)) MoveLast true false @@ -1027,14 +1023,14 @@ let get_previous_hyp_position id gl = aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) let intro_replacing id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let next_hyp = get_next_hyp_position id gl in Tacticals.New.tclTHENLIST [ clear_for_replacing [id]; introduction id; move_hyp id next_hyp; ] - end } + end (* We have e.g. [x, y, y', x', y'' |- forall y y' y'', G] and want to reintroduce y, y,' y''. Note that we have to clear y, y' and y'' @@ -1046,7 +1042,7 @@ let intro_replacing id = (* the behavior of inversion *) let intros_possibly_replacing ids = let suboptimal = true in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in Tacticals.New.tclTHEN (Tacticals.New.tclMAP (fun id -> @@ -1055,16 +1051,16 @@ let intros_possibly_replacing ids = (Tacticals.New.tclMAP (fun (id,pos) -> Tacticals.New.tclORELSE (intro_move (Some id) pos) (intro_using id)) posl) - end } + end (* This version assumes that replacement is actually possible *) let intros_replacing ids = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in Tacticals.New.tclTHEN (clear_for_replacing ids) (Tacticals.New.tclMAP (fun (id,pos) -> intro_move (Some id) pos) posl) - end } + end (* User-level introduction tactics *) @@ -1078,7 +1074,7 @@ let lookup_hypothesis_as_renamed_gen red h gl = match lookup_hypothesis_as_renamed env (Tacmach.New.project gl) ccl h with | None when red -> let (redfun, _) = Redexpr.reduction_of_red_expr env (Red true) in - let Sigma (c, _, _) = redfun.e_redfun env (Proofview.Goal.sigma gl) ccl in + let (_, c) = redfun env (Proofview.Goal.sigma gl) ccl in aux c | x -> x in @@ -1108,10 +1104,10 @@ let depth_of_quantified_hypothesis red h gl = str".") let intros_until_gen red h = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let n = depth_of_quantified_hypothesis red h gl in Tacticals.New.tclDO n (if red then introf else intro) - end } + end let intros_until_id id = intros_until_gen false (NamedHyp id) let intros_until_n_gen red n = intros_until_gen red (AnonHyp n) @@ -1120,10 +1116,10 @@ let intros_until = intros_until_gen true let intros_until_n = intros_until_n_gen true let tclCHECKVAR id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let _ = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in Proofview.tclUNIT () - end } + end let try_intros_until_id_check id = Tacticals.New.tclORELSE (intros_until_id id) (tclCHECKVAR id) @@ -1138,9 +1134,6 @@ let rec intros_move = function Tacticals.New.tclTHEN (intro_gen (NamingMustBe (Loc.tag hyp)) destopt false false) (intros_move rest) -let run_delayed env sigma c = - Sigma.run sigma { Sigma.run = fun sigma -> c.delayed env sigma } - (* Apply a tactic on a quantified hypothesis, an hypothesis in context or a term with bindings *) @@ -1154,7 +1147,7 @@ let tactic_infer_flags with_evar = { let onOpenInductionArg env sigma tac = function | clear_flag,ElimOnConstr f -> - let (cbl, sigma') = run_delayed env sigma f in + let (sigma', cbl) = f env sigma in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma') (tac clear_flag (sigma,cbl)) @@ -1163,18 +1156,18 @@ let onOpenInductionArg env sigma tac = function (intros_until_n n) (Tacticals.New.onLastHyp (fun c -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in tac clear_flag (sigma,(c,NoBindings)) - end })) + end)) | clear_flag,ElimOnIdent (_,id) -> (* A quantified hypothesis *) Tacticals.New.tclTHEN (try_intros_until_id_check id) - (Proofview.Goal.enter { enter = begin fun gl -> + (Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in tac clear_flag (sigma,(mkVar id,NoBindings)) - end }) + end) let onInductionArg tac = function | clear_flag,ElimOnConstr cbl -> @@ -1195,11 +1188,10 @@ let map_destruction_arg f sigma = function | clear_flag,ElimOnIdent id as x -> (sigma,x) let finish_delayed_evar_resolution with_evars env sigma f = - let ((c, lbind), sigma') = run_delayed env sigma f in - let sigma' = Sigma.Unsafe.of_evar_map sigma' in + let (sigma', (c, lbind)) = f env sigma in let flags = tactic_infer_flags with_evars in - let Sigma (c, sigma', _) = finish_evar_resolution ~flags env sigma' (sigma,c) in - (Sigma.to_evar_map sigma', (c, lbind)) + let (sigma', c) = finish_evar_resolution ~flags env sigma' (sigma,c) in + (sigma', (c, lbind)) let with_no_bindings (c, lbind) = if lbind != NoBindings then error "'with' clause not supported here."; @@ -1215,7 +1207,7 @@ let force_destruction_arg with_evars env sigma c = let normalize_cut = false let cut c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in @@ -1233,15 +1225,15 @@ let cut c = let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_of_hyps gl) in (** Backward compat: normalize [c]. *) let c = if normalize_cut then local_strong whd_betaiota sigma c else c in - Refine.refine ~unsafe:true { run = begin fun h -> - let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in - let Sigma (x, h, q) = Evarutil.new_evar env h c in + Refine.refine ~unsafe:true begin fun h -> + let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in + let (h, x) = Evarutil.new_evar env h c in let f = mkLetIn (Name id, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in - Sigma (f, h, p +> q) - end } + (h, f) + end else Tacticals.New.tclZEROMSG (str "Not a proposition or a type.") - end } + end let error_uninstantiated_metas t clenv = let t = EConstr.Unsafe.to_constr t in @@ -1352,12 +1344,12 @@ let enforce_prop_bound_names rename tac = mkLetIn (na,c,t,aux (push_rel (LocalDef (na,c,t)) env) sigma (i-1) t') | _ -> assert false in let rename_branch i = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let t = Proofview.Goal.concl gl in change_concl (aux env sigma i t) - end } in + end in (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) tac (Array.map rename_branch nn) @@ -1372,7 +1364,7 @@ let rec contract_letin_in_lam_header sigma c = let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags ()) rename i (elim, elimty, bindings) indclause = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let elim = contract_letin_in_lam_header sigma elim in @@ -1385,7 +1377,7 @@ let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in enforce_prop_bound_names rename (Clenvtac.res_pf elimclause' ~with_evars ~with_classes ~flags) - end } + end (* * Elimination tactic with bindings and using an arbitrary @@ -1402,7 +1394,7 @@ type eliminator = { } let general_elim_clause_gen elimtac indclause elim = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let (elimc,lbindelimc) = elim.elimbody in @@ -1410,10 +1402,10 @@ let general_elim_clause_gen elimtac indclause elim = let i = match elim.elimindex with None -> index_of_ind_arg sigma elimt | Some i -> i in elimtac elim.elimrename i (elimc, elimt, lbindelimc) indclause - end } + end let general_elim with_evars clear_flag (c, lbindc) elim = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ct = Retyping.get_type_of env sigma c in @@ -1425,32 +1417,30 @@ let general_elim with_evars clear_flag (c, lbindc) elim = Tacticals.New.tclTHEN (general_elim_clause_gen elimtac indclause elim) (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c) - end } + end (* Case analysis tactics *) let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in - let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in - let (mind,_) = reduce_to_quantified_ind env (Sigma.to_evar_map sigma) t in + let t = Retyping.get_type_of env sigma c in + let (mind,_) = reduce_to_quantified_ind env sigma t in let sort = Tacticals.New.elimination_sort_of_goal gl in - let mind = on_snd (fun u -> EInstance.kind (Sigma.to_evar_map sigma) u) mind in - let Sigma (elim, sigma, p) = - if occur_term (Sigma.to_evar_map sigma) c concl then + let mind = on_snd (fun u -> EInstance.kind sigma u) mind in + let (sigma, elim) = + if occur_term sigma c concl then build_case_analysis_scheme env sigma mind true sort else build_case_analysis_scheme_default env sigma mind sort in let elim = EConstr.of_constr elim in - let tac = + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (general_elim with_evars clear_flag (c,lbindc) {elimindex = None; elimbody = (elim,NoBindings); elimrename = Some (false, constructors_nrealdecls (fst mind))}) - in - Sigma (tac, sigma, p) - end } + end let general_case_analysis with_evars clear_flag (c,lbindc as cx) = Proofview.tclEVARMAP >>= fun sigma -> @@ -1486,13 +1476,11 @@ let find_eliminator c gl = let default_elim with_evars clear_flag (c,_ as cx) = Proofview.tclORELSE - (Proofview.Goal.s_enter { s_enter = begin fun gl -> + (Proofview.Goal.enter begin fun gl -> let sigma, elim = find_eliminator c gl in - let tac = - (general_elim with_evars clear_flag cx elim) - in - Sigma.Unsafe.of_pair (tac, sigma) - end }) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (general_elim with_evars clear_flag cx elim) + end) begin function (e, info) -> match e with | IsNonrec -> (* For records, induction principles aren't there by default @@ -1540,7 +1528,7 @@ let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause = let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) id rename i (elim, elimty, bindings) indclause = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let elim = contract_letin_in_lam_header sigma elim in @@ -1563,7 +1551,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) (str "Nothing to rewrite in " ++ pr_id id ++ str"."); clenv_refine_in with_evars id id sigma elimclause'' (fun id -> Proofview.tclUNIT ()) - end } + end let general_elim_clause with_evars flags id c e = let elim = match id with @@ -1622,7 +1610,7 @@ let make_projection env sigma params cstr sign elim i n c u = in elim let descend_in_conjunctions avoid tac (err, info) c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in try @@ -1641,14 +1629,13 @@ let descend_in_conjunctions avoid tac (err, info) c = try DefinedRecord (Recordops.lookup_projections ind) with Not_found -> let u = EInstance.kind sigma u in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (elim, _, _) = build_case_analysis_scheme env sigma (ind,u) false sort in + let (_, elim) = build_case_analysis_scheme env sigma (ind,u) false sort in let elim = EConstr.of_constr elim in NotADefinedRecordUseScheme elim in Tacticals.New.tclORELSE0 (Tacticals.New.tclFIRST (List.init n (fun i -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in match make_projection env sigma params cstr sign elim i n c u with @@ -1659,32 +1646,31 @@ let descend_in_conjunctions avoid tac (err, info) c = [Proofview.V82.tactic (refine p); (* Might be ill-typed due to forbidden elimination. *) Tacticals.New.onLastHypId (tac (not isrec))] - end }))) + end))) (Proofview.tclZERO ~info err) | None -> Proofview.tclZERO ~info err with RefinerError _|UserError _ -> Proofview.tclZERO ~info err - end } + end (****************************************************) (* Resolution tactics *) (****************************************************) let solve_remaining_apply_goals = - Proofview.Goal.s_enter { s_enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + Proofview.Goal.enter begin fun gl -> + let evd = Proofview.Goal.sigma gl in if !apply_solve_class_goals then try let env = Proofview.Goal.env gl in - let evd = Sigma.to_evar_map sigma in let concl = Proofview.Goal.concl gl in if Typeclasses.is_class_type evd concl then let evd', c' = Typeclasses.resolve_one_typeclass env evd concl in - let tac = Refine.refine ~unsafe:true { run = fun h -> Sigma.here c' h } in - Sigma.Unsafe.of_pair (tac, evd') - else Sigma.here (Proofview.tclUNIT ()) sigma - with Not_found -> Sigma.here (Proofview.tclUNIT ()) sigma - else Sigma.here (Proofview.tclUNIT ()) sigma - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd') + (Refine.refine ~unsafe:true (fun h -> (h,c'))) + else Proofview.tclUNIT () + with Not_found -> Proofview.tclUNIT () + else Proofview.tclUNIT () + end let tclORELSEOPT t k = Proofview.tclORELSE t @@ -1695,7 +1681,7 @@ let tclORELSEOPT t k = | Some tac -> tac) let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : EConstr.constr with_bindings)) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let flags = @@ -1705,7 +1691,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : step. *) let concl_nprod = nb_prod_modulo_zeta sigma concl in let rec try_main_apply with_destruct c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -1759,14 +1745,14 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : | PretypeError _|RefinerError _|UserError _|Failure _ -> Some (try_red_apply thm_ty0 (e, info)) | _ -> None) - end } + end in Tacticals.New.tclTHENLIST [ try_main_apply with_destruct c; solve_remaining_apply_goals; apply_clear_request clear_flag (use_clear_hyp_by_default ()) c ] - end } + end let rec apply_with_bindings_gen b e = function | [] -> Proofview.tclUNIT () @@ -1778,13 +1764,13 @@ let rec apply_with_bindings_gen b e = function let apply_with_delayed_bindings_gen b e l = let one k (loc, f) = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in - let (cb, sigma) = run_delayed env sigma f in + let (sigma, cb) = f env sigma in Tacticals.New.tclWITHHOLES e (general_apply b b e k (loc,cb)) sigma - end } + end in let rec aux = function | [] -> Proofview.tclUNIT () @@ -1861,7 +1847,7 @@ let apply_in_once_main flags innerclause env sigma (loc,d,lbind) = let apply_in_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,(d,lbind))) tac = let open Context.Rel.Declaration in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let flags = @@ -1870,7 +1856,7 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in let targetid = find_name true (LocalAssum (Anonymous,t')) naming gl in let rec aux idstoclear with_destruct c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in try @@ -1887,22 +1873,22 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming (descend_in_conjunctions [targetid] (fun b id -> aux (id::idstoclear) b (mkVar id)) (e, info) c) - end } + end in aux [] with_destruct d - end } + end let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,f)) tac = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let (c, sigma) = run_delayed env sigma f in + let (sigma, c) = f env sigma in Tacticals.New.tclWITHHOLES with_evars (apply_in_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,c)) tac) sigma - end } + end (* A useful resolution tactic which, if c:A->B, transforms |- C into |- B -> C and |- A @@ -1922,21 +1908,20 @@ let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars nam *) let cut_and_apply c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in match EConstr.kind sigma (Tacmach.New.pf_hnf_constr gl (Tacmach.New.pf_unsafe_type_of gl c)) with | Prod (_,c1,c2) when Vars.noccurn sigma 1 c2 -> let concl = Proofview.Goal.concl gl in let env = Tacmach.New.pf_env gl in - Refine.refine { run = begin fun sigma -> + Refine.refine begin fun sigma -> let typ = mkProd (Anonymous, c2, concl) in - let Sigma (f, sigma, p) = Evarutil.new_evar env sigma typ in - let Sigma (x, sigma, q) = Evarutil.new_evar env sigma c1 in - let ans = mkApp (f, [|mkApp (c, [|x|])|]) in - Sigma (ans, sigma, p +> q) - end } + let (sigma, f) = Evarutil.new_evar env sigma typ in + let (sigma, x) = Evarutil.new_evar env sigma c1 in + (sigma, mkApp (f, [|mkApp (c, [|x|])|])) + end | _ -> error "lapply needs a non-dependent product." - end } + end (********************************************************************) (* Exact tactics *) @@ -1949,42 +1934,38 @@ let cut_and_apply c = (* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *) let exact_no_check c = - Refine.refine ~unsafe:true { run = fun h -> Sigma.here c h } + Refine.refine ~unsafe:true (fun h -> (h,c)) let exact_check c = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in (** We do not need to normalize the goal because we just check convertibility *) let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map sigma in let sigma, ct = Typing.type_of env sigma c in - let tac = - Tacticals.New.tclTHEN (convert_leq ct concl) (exact_no_check c) - in - Sigma.Unsafe.of_pair (tac, sigma) - end } + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Tacticals.New.tclTHEN (convert_leq ct concl) (exact_no_check c)) + end let cast_no_check cast c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in exact_no_check (mkCast (c, cast, concl)) - end } + end let vm_cast_no_check c = cast_no_check Term.VMcast c let native_cast_no_check c = cast_no_check Term.NATIVEcast c let exact_proof c = let open Tacmach.New in - Proofview.Goal.enter { enter = begin fun gl -> - Refine.refine { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in + Proofview.Goal.enter begin fun gl -> + Refine.refine begin fun sigma -> let (c, ctx) = Constrintern.interp_casted_constr (pf_env gl) sigma c (pf_concl gl) in let c = EConstr.of_constr c in let sigma = Evd.merge_universe_context sigma ctx in - Sigma.Unsafe.of_pair (c, sigma) - end } - end } + (sigma, c) + end + end let assumption = let rec arec gl only_eq = function @@ -2008,10 +1989,10 @@ let assumption = exact_no_check (mkVar (NamedDecl.get_id decl)) else arec gl only_eq rest in - let assumption_tac = { enter = begin fun gl -> + let assumption_tac gl = let hyps = Proofview.Goal.hyps gl in arec gl true hyps - end } in + in Proofview.Goal.enter assumption_tac (*****************************************************************) @@ -2050,7 +2031,7 @@ let check_decl env sigma decl = let clear_body ids = let open Context.Named.Declaration in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let sigma = Tacmach.New.project gl in @@ -2095,10 +2076,10 @@ let clear_body ids = Tacticals.New.tclZEROMSG msg in check <*> - Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true begin fun sigma -> Evarutil.new_evar env sigma ~principal:true concl - end } - end } + end + end let clear_wildcards ids = Tacticals.New.tclMAP (fun (loc, id) -> clear [id]) ids @@ -2117,7 +2098,7 @@ let rec intros_clearing = function (* Keeping only a few hypotheses *) let keep hyps = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> Proofview.tclENV >>= fun env -> let ccl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in @@ -2133,7 +2114,7 @@ let keep hyps = ~init:([],[]) (Proofview.Goal.env gl) in clear cl - end } + end (*********************************) (* Basic generalization tactics *) @@ -2144,16 +2125,16 @@ let keep hyps = this generalizes [hyps |- goal] into [hyps |- T] *) let apply_type newcl args = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in - Refine.refine { run = begin fun sigma -> - let newcl = nf_betaiota (Sigma.to_evar_map sigma) newcl (* As in former Logic.refine *) in - let Sigma (ev, sigma, p) = + Refine.refine begin fun sigma -> + let newcl = nf_betaiota sigma newcl (* As in former Logic.refine *) in + let (sigma, ev) = Evarutil.new_evar env sigma ~principal:true ~store newcl in - Sigma (applist (ev, args), sigma, p) - end } - end } + (sigma, applist (ev, args)) + end + end (* Given a context [hyps] with domain [x1..xn], possibly with let-ins, and well-typed in the current goal, [bring_hyps hyps] generalizes @@ -2162,25 +2143,25 @@ let apply_type newcl args = let bring_hyps hyps = if List.is_empty hyps then Tacticals.New.tclIDTAC else - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let concl = Tacmach.New.pf_concl gl in let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in let args = Array.of_list (Context.Named.to_instance mkVar hyps) in - Refine.refine { run = begin fun sigma -> - let Sigma (ev, sigma, p) = + Refine.refine begin fun sigma -> + let (sigma, ev) = Evarutil.new_evar env sigma ~principal:true ~store newcl in - Sigma (mkApp (ev, args), sigma, p) - end } - end } + (sigma, mkApp (ev, args)) + end + end let revert hyps = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let gl = Proofview.Goal.assume gl in let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in (bring_hyps ctx) <*> (clear hyps) - end } + end (************************) (* Introduction tactics *) @@ -2197,7 +2178,7 @@ let check_number_of_constructors expctdnumopt i nconstr = if i > nconstr then error "Not enough constructors." let constructor_tac with_evars expctdnumopt i lbind = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let cl = Tacmach.New.pf_concl gl in let reduce_to_quantified_ind = @@ -2208,19 +2189,16 @@ let constructor_tac with_evars expctdnumopt i lbind = Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in check_number_of_constructors expctdnumopt i nconstr; - let Sigma ((cons, u), sigma, p) = Sigma.fresh_constructor_instance + let (sigma, (cons, u)) = Evd.fresh_constructor_instance (Proofview.Goal.env gl) sigma (fst mind, i) in let cons = mkConstructU (cons, EInstance.make u) in let apply_tac = general_apply true false with_evars None (Loc.tag (cons,lbind)) in - let tac = - (Tacticals.New.tclTHENLIST - [ - convert_concl_no_check redcl DEFAULTcast; - intros; apply_tac]) - in - Sigma (tac, sigma, p) - end } + Tacticals.New.tclTHENLIST + [ Proofview.Unsafe.tclEVARS sigma; + convert_concl_no_check redcl DEFAULTcast; + intros; apply_tac] + end let one_constructor i lbind = constructor_tac false None i lbind @@ -2237,7 +2215,7 @@ let rec tclANY tac = function let any_constructor with_evars tacopt = let t = match tacopt with None -> Proofview.tclUNIT () | Some t -> t in let tac i = Tacticals.New.tclTHEN (constructor_tac with_evars None i NoBindings) t in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let cl = Tacmach.New.pf_concl gl in let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl @@ -2247,7 +2225,7 @@ let any_constructor with_evars tacopt = Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in if Int.equal nconstr 0 then error "The type has no constructors."; tclANY tac (List.interval 1 nconstr) - end } + end let left_with_bindings with_evars = constructor_tac with_evars (Some 2) 1 let right_with_bindings with_evars = constructor_tac with_evars (Some 2) 2 @@ -2298,7 +2276,7 @@ let my_find_eq_data_decompose gl t = | Constr_matching.PatternMatchingFailure -> None let intro_decomp_eq ?loc l thin tac id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in @@ -2309,10 +2287,10 @@ let intro_decomp_eq ?loc l thin tac id = (eq,t,eq_args) (c, t) | None -> Tacticals.New.tclZEROMSG (str "Not a primitive equality here.") - end } + end let intro_or_and_pattern ?loc with_evars bracketed ll thin tac id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in @@ -2324,7 +2302,7 @@ let intro_or_and_pattern ?loc with_evars bracketed ll thin tac id = (Tacticals.New.tclTHEN (simplest_ecase c) (clear [id])) (Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l) nv_with_let ll) - end } + end let rewrite_hyp_then assert_style with_evars thin l2r id tac = let rew_on l2r = @@ -2334,7 +2312,7 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = let clear_var_and_eq id' = clear [id';id] in let early_clear id' thin = List.filter (fun (_,id) -> not (Id.equal id id')) thin in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in @@ -2366,7 +2344,7 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = thin in (* Skip the side conditions of the rewriting step *) Tacticals.New.tclTHENFIRST eqtac (tac thin) - end } + end let prepare_naming ?loc = function | IntroIdentifier id -> NamingMustBe (Loc.tag ?loc id) @@ -2525,10 +2503,8 @@ and intro_pattern_action ?loc with_evars b style pat thin destopt tac id = Proofview.tclUNIT () (* apply_in_once do a replacement *) else clear [id] in - let f = { delayed = fun env sigma -> - let Sigma (c, sigma, p) = f.delayed env sigma in - Sigma ((c, NoBindings), sigma, p) - } in + let f env sigma = let (sigma, c) = f env sigma in (sigma,(c, NoBindings)) + in apply_in_delayed_once false true true with_evars naming id (None,(loc',f)) (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) @@ -2547,12 +2523,12 @@ and prepare_intros ?loc with_evars dft destopt = function (str "Introduction pattern for one hypothesis expected.") let intro_patterns_head_core with_evars b destopt bound pat = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in check_name_unicity env [] [] pat; intro_patterns_core with_evars b [] [] [] destopt bound 0 (fun _ l -> clear_wildcards l) pat - end } + end let intro_patterns_bound_to with_evars n destopt = intro_patterns_head_core with_evars true destopt @@ -2602,7 +2578,7 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars let tac (naming,lemma) tac id = apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming id lemma tac in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let destopt = if with_evars then MoveLast (* evars would depend on the whole context *) else get_previous_hyp_position id gl in @@ -2614,7 +2590,7 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars in (* We chain apply_in_once, ending with an intro pattern *) List.fold_right tac lemmas_target (tac last_lemma_target ipat_tac) id - end } + end (* if sidecond_first then @@ -2625,7 +2601,7 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars *) let apply_in simple with_evars id lemmas ipat = - let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, { delayed = fun _ sigma -> Sigma.here l sigma })) lemmas in + let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, (fun _ sigma -> (sigma,l)))) lemmas in general_apply_in false simple simple with_evars id lemmas ipat let apply_delayed_in simple with_evars id lemmas ipat = @@ -2649,17 +2625,16 @@ let decode_hyp = function *) let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let Sigma (t, sigma, p) = match ty with - | Some t -> Sigma.here t sigma + let (sigma, t) = match ty with + | Some t -> (sigma, t) | None -> let t = typ_of env sigma c in - let sigma, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env (Sigma.to_evar_map sigma) t in - Sigma.Unsafe.of_pair (c, sigma) + Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t in - let Sigma ((newcl, eq_tac), sigma, q) = match with_eq with + let (sigma, (newcl, eq_tac)) = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with | IntroAnonymous -> new_fresh_id [id] (add_prefix "Heq" id) gl @@ -2667,33 +2642,31 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = | IntroIdentifier id -> id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in - let Sigma (eq, sigma, p) = Sigma.fresh_global env sigma eqdata.eq in + let (sigma, eq) = Evd.fresh_global env sigma eqdata.eq in let eq = EConstr.of_constr eq in - let Sigma (refl, sigma, q) = Sigma.fresh_global env sigma eqdata.refl in + let (sigma, refl) = Evd.fresh_global env sigma eqdata.refl in let refl = EConstr.of_constr refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in let term = mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)) in - let sigma = Sigma.to_evar_map sigma in let sigma, _ = Typing.type_of env sigma term in let ans = term, - Tacticals.New.tclTHEN - (intro_gen (NamingMustBe (loc,heq)) (decode_hyp lastlhyp) true false) - (clear_body [heq;id]) + Tacticals.New.tclTHENLIST + [ + intro_gen (NamingMustBe (loc,heq)) (decode_hyp lastlhyp) true false; + clear_body [heq;id]] in - Sigma.Unsafe.of_pair (ans, sigma) + (sigma, ans) | None -> - Sigma.here (mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) sigma + (sigma, (mkNamedLetIn id c t ccl, Proofview.tclUNIT ())) in - let tac = Tacticals.New.tclTHENLIST - [ convert_concl_no_check newcl DEFAULTcast; + [ Proofview.Unsafe.tclEVARS sigma; + convert_concl_no_check newcl DEFAULTcast; intro_gen (NamingMustBe (Loc.tag id)) (decode_hyp lastlhyp) true false; Tacticals.New.tclMAP convert_hyp_no_check depdecls; eq_tac ] - in - Sigma (tac, sigma, p +> q) - end } + end let insert_before decls lasthyp env = match lasthyp with @@ -2725,22 +2698,22 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in - let Sigma (eq, sigma, p) = Sigma.fresh_global env sigma eqdata.eq in + let (sigma, eq) = Evd.fresh_global env sigma eqdata.eq in let eq = EConstr.of_constr eq in - let Sigma (refl, sigma, q) = Sigma.fresh_global env sigma eqdata.refl in + let (sigma, refl) = Evd.fresh_global env sigma eqdata.refl in let refl = EConstr.of_constr refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in let newenv = insert_before [LocalAssum (heq,eq); decl] lastlhyp env in - let Sigma (x, sigma, r) = new_evar newenv sigma ~principal:true ~store ccl in - Sigma (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x), sigma, p +> q +> r) + let (sigma, x) = new_evar newenv sigma ~principal:true ~store ccl in + (sigma, mkNamedLetIn id c t (mkNamedLetIn heq refl eq x)) | None -> let newenv = insert_before [decl] lastlhyp env in - let Sigma (x, sigma, p) = new_evar newenv sigma ~principal:true ~store ccl in - Sigma (mkNamedLetIn id c t x, sigma, p) + let (sigma, x) = new_evar newenv sigma ~principal:true ~store ccl in + (sigma, mkNamedLetIn id c t x) let letin_tac with_eq id c ty occs = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in @@ -2748,41 +2721,39 @@ let letin_tac with_eq id c ty occs = let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in (* We keep the original term to match but record the potential side-effects of unifying universes. *) - let Sigma (c, sigma, p) = match res with - | None -> Sigma.here c sigma - | Some (Sigma (_, sigma, p)) -> Sigma (c, sigma, p) + let (sigma, c) = match res with + | None -> (sigma, c) + | Some (sigma, _) -> (sigma, c) in - let tac = letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty in - Sigma (tac, sigma, p) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty) + end let letin_pat_tac with_evars with_eq id c occs = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in let check t = true in let abs = AbstractPattern (false,check,id,c,occs,false) in let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in - let Sigma (c, sigma, p) = match res with + let (sigma, c) = match res with | None -> finish_evar_resolution ~flags:(tactic_infer_flags with_evars) env sigma c | Some res -> res in - let tac = - (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None) - in - Sigma (tac, sigma, p) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None) + end (* Tactics "pose proof" (usetac=None) and "assert"/"enough" (otherwise) *) let forward b usetac ipat c = match usetac with | None -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let t = Tacmach.New.pf_get_type_of gl c in let sigma = Tacmach.New.project gl in let hd = head_ident sigma c in Tacticals.New.tclTHENFIRST (assert_as true hd ipat t) (exact_no_check c) - end } + end | Some tac -> let tac = match tac with | None -> Tacticals.New.tclIDTAC @@ -2847,7 +2818,7 @@ let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = let generalize_dep ?(with_let=false) c = let open Tacmach.New in let open Tacticals.New in - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.nf_enter begin fun gl -> let env = pf_env gl in let sign = Proofview.Goal.hyps gl in let sigma = project gl in @@ -2881,16 +2852,14 @@ let generalize_dep ?(with_let=false) c = (** Check that the generalization is indeed well-typed *) let (evd, _) = Typing.type_of env evd cl'' in let args = Context.Named.to_instance mkVar to_quantify_rev in - let tac = - tclTHEN - (apply_type cl'' (if Option.is_empty body then c::args else args)) - (clear (List.rev tothin')) - in - Sigma.Unsafe.of_pair (tac, evd) - end } + tclTHENLIST + [ Proofview.Unsafe.tclEVARS evd; + apply_type cl'' (if Option.is_empty body then c::args else args); + clear (List.rev tothin')] + end (** *) -let generalize_gen_let lconstr = Proofview.Goal.s_enter { s_enter = begin fun gl -> +let generalize_gen_let lconstr = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let newcl, evd = List.fold_right_i (generalize_goal gl) 0 lconstr @@ -2898,16 +2867,15 @@ let generalize_gen_let lconstr = Proofview.Goal.s_enter { s_enter = begin fun gl in let (evd, _) = Typing.type_of env evd newcl in let map ((_, c, b),_) = if Option.is_empty b then Some c else None in - let tac = apply_type newcl (List.map_filter map lconstr) in - Sigma.Unsafe.of_pair (tac, evd) -end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) + (apply_type newcl (List.map_filter map lconstr)) +end let new_generalize_gen_let lconstr = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in - let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let ids = Tacmach.New.pf_ids_of_hyps gl in let newcl, sigma, args = @@ -2919,14 +2887,12 @@ let new_generalize_gen_let lconstr = (cl, sigma, args)) 0 lconstr (concl, sigma, []) in - let tac = - Refine.refine { run = begin fun sigma -> - let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true newcl in - Sigma ((applist (ev, args)), sigma, p) - end } - in - Sigma.Unsafe.of_pair (tac, sigma) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Refine.refine begin fun sigma -> + let (sigma, ev) = Evarutil.new_evar env sigma ~principal:true newcl in + (sigma, applist (ev, args)) + end) + end let generalize_gen lconstr = generalize_gen_let (List.map (fun (occs_c,na) -> @@ -2968,9 +2934,9 @@ let quantify lconstr = of inferred args and yi. The overall effect is to remove from H as much quantification as possible given lbind. *) let specialize (c,lbind) ipat = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let sigma = Proofview.Goal.sigma gl in let sigma, term = if lbind == NoBindings then sigma, c @@ -3046,7 +3012,7 @@ let specialize (c,lbind) ipat = (exact_no_check term) in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) tac - end } + end (*****************************) (* Ad hoc unfold *) @@ -3056,7 +3022,7 @@ let specialize (c,lbind) ipat = (* Unfolds x by its definition everywhere *) let unfold_body x = let open Context.Named.Declaration in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> (** We normalize the given hypothesis immediately. *) let env = Proofview.Goal.env (Proofview.Goal.assume gl) in let xval = match Environ.lookup_named x env with @@ -3072,7 +3038,7 @@ let unfold_body x = let reductc = reduct_in_concl (rfun, DEFAULTcast) in Tacticals.New.tclTHENLIST [Tacticals.New.tclMAP reducth hl; reductc] end - end } + end (* Either unfold and clear if defined or simply clear if not a definition *) let expand_hyp id = Tacticals.New.tclTRY (unfold_body id) <*> clear [id] @@ -3117,7 +3083,7 @@ let warn_unused_intro_pattern = strbrk"Unused introduction " ++ str (String.plural (List.length names) "pattern") ++ str": " ++ prlist_with_sep spc (Miscprint.pr_intro_pattern - (fun c -> Printer.pr_econstr (fst (run_delayed (Global.env()) Evd.empty c)))) names) + (fun c -> Printer.pr_econstr (snd (c (Global.env()) Evd.empty)))) names) let check_unused_names names = if not (List.is_empty names) then @@ -3201,7 +3167,7 @@ let induct_discharge with_evars dests avoid' tac (avoid,ra) names = match ra with | (RecArg,_,deprec,recvarname) :: (IndArg,_,depind,hyprecname) :: ra' -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (recpat,names) = match names with | [loc,IntroNaming (IntroIdentifier id) as pat] -> let id' = next_ident_away (add_prefix "IH" id) avoid in @@ -3209,37 +3175,37 @@ let induct_discharge with_evars dests avoid' tac (avoid,ra) names = | _ -> consume_pattern avoid (Name recvarname) deprec gl names in let dest = get_recarg_dest dests in dest_intro_patterns with_evars avoid thin dest [recpat] (fun ids thin -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (hyprec,names) = consume_pattern avoid (Name hyprecname) depind gl names in dest_intro_patterns with_evars avoid thin MoveLast [hyprec] (fun ids' thin -> peel_tac ra' (update_dest dests ids') names thin) - end }) - end } + end) + end | (IndArg,_,dep,hyprecname) :: ra' -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> (* Rem: does not happen in Coq schemes, only in user-defined schemes *) let pat,names = consume_pattern avoid (Name hyprecname) dep gl names in dest_intro_patterns with_evars avoid thin MoveLast [pat] (fun ids thin -> peel_tac ra' (update_dest dests ids) names thin) - end } + end | (RecArg,_,dep,recvarname) :: ra' -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (pat,names) = consume_pattern avoid (Name recvarname) dep gl names in let dest = get_recarg_dest dests in dest_intro_patterns with_evars avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) - end } + end | (OtherArg,_,dep,_) :: ra' -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (pat,names) = consume_pattern avoid Anonymous dep gl names in let dest = get_recarg_dest dests in safe_dest_intro_patterns with_evars avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) - end } + end | [] -> check_unused_names names; Tacticals.New.tclTHEN (clear_wildcards thin) (tac dests) @@ -3262,7 +3228,7 @@ let expand_projections env sigma c = (* Marche pas... faut prendre en compte l'occurrence précise... *) let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 (Proofview.Goal.assume gl) in @@ -3316,7 +3282,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = (atomize_one (i-1) (mkVar x::args) (mkVar x::args') (x::avoid)) in atomize_one (List.length argl) [] [] [] - end } + end (* [cook_sign] builds the lists [beforetoclear] (preceding the ind. var.) and [aftertoclear] (coming after the ind. var.) of hyps @@ -3561,16 +3527,12 @@ let error_ind_scheme s = let s = if not (String.is_empty s) then s^" " else s in user_err ~hdr:"Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.") -let glob sigma gr = - let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map sigma) gr - in Sigma.to_evar_map sigma, c - -let coq_eq sigma = glob sigma (Coqlib.build_coq_eq ()) -let coq_eq_refl sigma = glob sigma (Coqlib.build_coq_eq_refl ()) +let coq_eq sigma = Evarutil.new_global sigma (Coqlib.build_coq_eq ()) +let coq_eq_refl sigma = Evarutil.new_global sigma (Coqlib.build_coq_eq_refl ()) let coq_heq_ref = lazy (Coqlib.coq_reference"mkHEq" ["Logic";"JMeq"] "JMeq") -let coq_heq sigma = glob sigma (Lazy.force coq_heq_ref) -let coq_heq_refl sigma = glob sigma (Coqlib.coq_reference "mkHEq" ["Logic";"JMeq"] "JMeq_refl") +let coq_heq sigma = Evarutil.new_global sigma (Lazy.force coq_heq_ref) +let coq_heq_refl sigma = Evarutil.new_global sigma (Coqlib.coq_reference "mkHEq" ["Logic";"JMeq"] "JMeq_refl") let mkEq sigma t x y = let sigma, eq = coq_eq sigma in @@ -3625,25 +3587,24 @@ let decompose_indapp sigma f args = | _ -> f, args let mk_term_eq homogeneous env sigma ty t ty' t' = - let sigma = Sigma.to_evar_map sigma in if homogeneous then let sigma, eq = mkEq sigma ty t t' in let sigma, refl = mkRefl sigma ty' t' in - Sigma.Unsafe.of_evar_map sigma, (eq, refl) + sigma, (eq, refl) else let sigma, heq = mkHEq sigma ty t ty' t' in let sigma, hrefl = mkHRefl sigma ty' t' in - Sigma.Unsafe.of_evar_map sigma, (heq, hrefl) + sigma, (heq, hrefl) let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = let open Context.Rel.Declaration in - Refine.refine { run = begin fun sigma -> + Refine.refine begin fun sigma -> let eqslen = List.length eqs in (* Abstract by the "generalized" hypothesis equality proof if necessary. *) let sigma, abshypeq, abshypt = if dep then let ty = lift 1 c in - let homogeneous = Reductionops.is_conv env (Sigma.to_evar_map sigma) ty typ in + let homogeneous = Reductionops.is_conv env sigma ty typ in let sigma, (eq, refl) = mk_term_eq homogeneous (push_rel_context ctx env) sigma ty (mkRel 1) typ (mkVar id) in sigma, mkProd (Anonymous, eq, lift 1 concl), [| refl |] @@ -3661,7 +3622,7 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = (* Abstract by the extension of the context *) let genctyp = it_mkProd_or_LetIn genarg ctx in (* The goal will become this product. *) - let Sigma (genc, sigma, p) = Evarutil.new_evar env sigma ~principal:true genctyp in + let (sigma, genc) = Evarutil.new_evar env sigma ~principal:true genctyp in (* Apply the old arguments giving the proper instantiation of the hyp *) let instc = mkApp (genc, Array.of_list args) in (* Then apply to the original instantiated hyp. *) @@ -3669,8 +3630,8 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = (* Apply the reflexivity proofs on the indices. *) let appeqs = mkApp (instc, Array.of_list refls) in (* Finally, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) - Sigma (mkApp (appeqs, abshypt), sigma, p) - end } + (sigma, mkApp (appeqs, abshypt)) + end let hyps_of_vars env sigma sign nogen hyps = if Id.Set.is_empty hyps then [] @@ -3802,7 +3763,7 @@ let abstract_args gl generalize_vars dep id defined f args = let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = let open Context.Named.Declaration in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> Coqlib.check_required_library Coqlib.jmeq_module_name; let sigma = Tacmach.New.project gl in let (f, args, def, id, oldid) = @@ -3838,7 +3799,7 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = [revert vars ; Tacticals.New.tclMAP (fun id -> Tacticals.New.tclTRY (generalize_dep ~with_let:true (mkVar id))) vars]) - end } + end let compare_upto_variables sigma x y = let rec compare x y = @@ -3899,12 +3860,12 @@ let specialize_eqs id gl = else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl -let specialize_eqs id = Proofview.Goal.enter { enter = begin fun gl -> +let specialize_eqs id = Proofview.Goal.enter begin fun gl -> let msg = str "Specialization not allowed on dependent hypotheses" in Proofview.tclOR (clear [id]) (fun _ -> Tacticals.New.tclZEROMSG msg) >>= fun () -> Proofview.V82.tactic (specialize_eqs id) -end } +end let occur_rel sigma n c = let res = not (noccurn sigma n c) in @@ -4118,17 +4079,17 @@ let guess_elim isrec dep s hyp0 gl = if isrec && not (is_nonrec mind) then find_ind_eliminator mind s gl else let env = Tacmach.New.pf_env gl in - let sigma = Sigma.Unsafe.of_evar_map (Tacmach.New.project gl) in + let sigma = Tacmach.New.project gl in let u = EInstance.kind (Tacmach.New.project gl) u in if use_dependent_propositions_elimination () && dep then - let Sigma (ind, sigma, _) = build_case_analysis_scheme env sigma (mind, u) true s in + let (sigma, ind) = build_case_analysis_scheme env sigma (mind, u) true s in let ind = EConstr.of_constr ind in - (Sigma.to_evar_map sigma, ind) + (sigma, ind) else - let Sigma (ind, sigma, _) = build_case_analysis_scheme_default env sigma (mind, u) s in + let (sigma, ind) = build_case_analysis_scheme_default env sigma (mind, u) s in let ind = EConstr.of_constr ind in - (Sigma.to_evar_map sigma, ind) + (sigma, ind) in let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in evd, ((elimc, NoBindings), elimt), mkIndU (mind, u) @@ -4235,7 +4196,7 @@ let recolle_clenv i params args elimclause gl = produce new ones). Then refine with the resulting term with holes. *) let induction_tac with_evars params indvars elim = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let ({elimindex=i;elimbody=(elimc,lbindelimc);elimrename=rename},elimt) = elim in let i = match i with None -> index_of_ind_arg sigma elimt | Some i -> i in @@ -4248,17 +4209,16 @@ let induction_tac with_evars params indvars elim = (* one last resolution (useless?) *) let resolved = clenv_unique_resolver ~flags:(elim_flags ()) elimclause' gl in enforce_prop_bound_names rename (Clenvtac.clenv_refine with_evars resolved) - end } + end (* Apply induction "in place" taking into account dependent hypotheses from the context, replacing the main hypothesis on which induction applies with the induction hypotheses *) let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_tac = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map sigma in let concl = Tacmach.New.pf_concl gl in let statuslists,lhyp0,toclear,deps,avoid,dep_in_hyps = cook_sign hyp0 inhyps indvars env sigma in let dep_in_concl = Option.cata (fun id -> occur_var env sigma id concl) false hyp0 in @@ -4288,16 +4248,16 @@ let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_ (re_intro_dependent_hypotheses statuslists)) indsign names) in - Sigma.Unsafe.of_pair (tac, sigma) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) tac + end let induction_with_atomization_of_ind_arg isrec with_evars elim names hyp0 inhyps = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let elim_info = find_induction_type isrec elim hyp0 (Proofview.Goal.assume gl) in atomize_param_of_ind_then elim_info hyp0 (fun indvars -> apply_induction_in_context with_evars (Some hyp0) inhyps (pi3 elim_info) indvars names (fun elim -> induction_tac with_evars [] [hyp0] elim)) - end } + end let msg_not_right_number_induction_arguments scheme = str"Not the right number of induction arguments (expected " ++ @@ -4314,7 +4274,7 @@ let msg_not_right_number_induction_arguments scheme = must be given, so we help a bit the unifier by making the "pattern" by hand before calling induction_tac *) let induction_without_atomization isrec with_evars elim names lid = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma, (indsign,scheme) = get_elim_signature elim (List.hd lid) gl in let nargs_indarg_farg = scheme.nargs + (if scheme.farg_in_concl then 1 else 0) in @@ -4345,11 +4305,11 @@ let induction_without_atomization isrec with_evars elim names lid = ] in let elim = ElimUsing (({elimindex = Some (-1); elimbody = Option.get scheme.elimc; elimrename = None}, scheme.elimt), indsign) in apply_induction_in_context with_evars None [] elim indvars names induct_tac - end } + end (* assume that no occurrences are selected *) let clear_unselected_context id inhyps cls = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> if occur_var (Tacmach.New.pf_env gl) (Tacmach.New.project gl) id (Tacmach.New.pf_concl gl) && cls.concl_occs == NoOccurrences then user_err @@ -4367,10 +4327,9 @@ let clear_unselected_context id inhyps cls = let ids = List.map_filter to_erase (Proofview.Goal.hyps gl) in clear ids | None -> Proofview.tclUNIT () - end } + end let use_bindings env sigma elim must_be_closed (c,lbind) typ = - let sigma = Sigma.to_evar_map sigma in let typ = if elim == None then (* w/o an scheme, the term has to be applied at least until @@ -4392,8 +4351,7 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ = if must_be_closed && occur_meta indclause.evd (clenv_value indclause) then error "Need a fully applied argument."; (* We lose the possibility of coercions in with-bindings *) - let (sigma, c) = pose_all_metas_as_evars env indclause.evd (clenv_value indclause) in - Sigma.Unsafe.of_pair (c, sigma) + pose_all_metas_as_evars env indclause.evd (clenv_value indclause) with e when catchable_exception e -> try find_clause (try_red_product env sigma typ) with Redelimination -> raise e in @@ -4411,7 +4369,6 @@ let check_expected_type env sigma (elimc,bl) elimt = fun t -> Evarconv.e_cumul env (ref sigma) t u let check_enough_applied env sigma elim = - let sigma = Sigma.to_evar_map sigma in (* A heuristic to decide whether the induction arg is enough applied *) match elim with | None -> @@ -4436,13 +4393,13 @@ let guard_no_unifiable = Proofview.guard_no_unifiable >>= function let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim id ((pending,(c0,lbind)),(eqname,names)) t0 inhyps cls tac = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in let store = Proofview.Goal.extra gl in let check = check_enough_applied env sigma elim in - let Sigma (c, sigma', p) = use_bindings env sigma elim false (c0,lbind) t0 in + let (sigma', c) = use_bindings env sigma elim false (c0,lbind) t0 in let abs = AbstractPattern (from_prefix,check,Name id,(pending,c),cls,false) in let (id,sign,_,lastlhyp,ccl,res) = make_abstraction env sigma' ccl abs in match res with @@ -4452,7 +4409,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim (* we restart using bindings after having tried type-class resolution etc. on the term given by the user *) let flags = tactic_infer_flags (with_evars && (* do not give a success semantics to edestruct on an open term yet *) false) in - let Sigma (c0, sigma, q) = finish_evar_resolution ~flags env sigma (pending,c0) in + let (sigma, c0) = finish_evar_resolution ~flags env sigma (pending,c0) in let tac = (if isrec then (* Historically, induction has side conditions last *) @@ -4461,13 +4418,12 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim (* and destruct has side conditions first *) Tacticals.New.tclTHENLAST) (Tacticals.New.tclTHENLIST [ - Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true begin fun sigma -> let b = not with_evars && with_eq != None in - let Sigma (c, sigma, p) = use_bindings env sigma elim b (c0,lbind) t0 in - let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in - let Sigma (ans, sigma, q) = mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t) in - Sigma (ans, sigma, p +> q) - end }; + let (sigma, c) = use_bindings env sigma elim b (c0,lbind) t0 in + let t = Retyping.get_type_of env sigma c in + mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t) + end; if with_evars then Proofview.shelve_unifiable else guard_no_unifiable; if is_arg_pure_hyp then Proofview.tclEVARMAP >>= fun sigma -> Tacticals.New.tclTRY (clear [destVar sigma c0]) @@ -4476,23 +4432,23 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim ]) tac in - Sigma (tac, sigma, q) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) tac - | Some (Sigma (c, sigma', q)) -> + | Some (sigma', c) -> (* pattern found *) let with_eq = Option.map (fun eq -> (false,eq)) eqname in (* TODO: if ind has predicate parameters, use JMeq instead of eq *) let env = reset_with_named_context sign env in let tac = Tacticals.New.tclTHENLIST [ - Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true begin fun sigma -> mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None - end }; + end; tac ] in - Sigma (tac, sigma', p +> q) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma') tac + end let has_generic_occurrences_but_goal cls id env sigma ccl = clause_with_generic_context_selection cls && @@ -4504,19 +4460,18 @@ let induction_gen clear_flag isrec with_evars elim let inhyps = match cls with | Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps | _ -> [] in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in - let evd = Sigma.to_evar_map sigma in + let evd = Proofview.Goal.sigma gl in let ccl = Proofview.Goal.concl gl in let cls = Option.default allHypsAndConcl cls in - let t = typ_of env sigma c in + let t = typ_of env evd c in let is_arg_pure_hyp = isVar evd c && not (mem_named_context_val (destVar evd c) (Global.named_context_val ())) && lbind == NoBindings && not with_evars && Option.is_empty eqname && clear_flag == None && has_generic_occurrences_but_goal cls (destVar evd c) env evd ccl in - let enough_applied = check_enough_applied env sigma elim t in + let enough_applied = check_enough_applied env evd elim t in if is_arg_pure_hyp && enough_applied then (* First case: induction on a variable already in an inductive type and with maximal abstraction over the variable. @@ -4540,7 +4495,7 @@ let induction_gen clear_flag isrec with_evars elim isrec with_evars info_arg elim id arg t inhyps cls (induction_with_atomization_of_ind_arg isrec with_evars elim names id inhyps) - end } + end (* Induction on a list of arguments. First make induction arguments atomic (using letins), then do induction. The specificity here is @@ -4566,7 +4521,7 @@ let induction_gen_l isrec with_evars elim names lc = atomize_list l' | _ -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in let sigma = Tacmach.New.project gl in let x = @@ -4578,7 +4533,7 @@ let induction_gen_l isrec with_evars elim names lc = Tacticals.New.tclTHEN (letin_tac None (Name id) c None allHypsAndConcl) (atomize_list newl') - end } in + end in Tacticals.New.tclTHENLIST [ (atomize_list lc); @@ -4595,7 +4550,7 @@ let induction_destruct isrec with_evars (lc,elim) = match lc with | [] -> assert false (* ensured by syntax, but if called inside caml? *) | [c,(eqname,names as allnames),cls] -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in match elim with @@ -4612,9 +4567,9 @@ let induction_destruct isrec with_evars (lc,elim) = (* standard induction *) onOpenInductionArg env sigma (fun clear_flag c -> induction_gen clear_flag isrec with_evars elim (c,allnames) cls) c - end } + end | _ -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in match elim with @@ -4630,12 +4585,12 @@ let induction_destruct isrec with_evars (lc,elim) = (onOpenInductionArg env sigma (fun clear_flag a -> induction_gen clear_flag isrec with_evars None (a,b) cl) a) (Tacticals.New.tclMAP (fun (a,b,cl) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in onOpenInductionArg env sigma (fun clear_flag a -> induction_gen clear_flag false with_evars None (a,b) cl) a - end }) l) + end) l) | Some elim -> (* Several induction hyps with induction scheme *) let lc = List.map (on_pi1 (fun c -> snd (force_destruction_arg false env sigma c))) lc in @@ -4654,7 +4609,7 @@ let induction_destruct isrec with_evars (lc,elim) = error "'as' clause with multiple arguments and 'using' clause can only occur last."; let newlc = List.map (fun (x,_) -> (x,None)) newlc in induction_gen_l isrec with_evars elim names newlc - end } + end let induction ev clr c l e = induction_gen clr true ev e @@ -4696,7 +4651,7 @@ let simple_destruct = function *) let elim_scheme_type elim t = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let clause = mk_clenv_type_of gl elim in match EConstr.kind clause.evd (last_arg clause.evd clause.templval.rebus) with | Meta mv -> @@ -4706,26 +4661,26 @@ let elim_scheme_type elim t = (clenv_meta_type clause mv) clause in Clenvtac.res_pf clause' ~flags:(elim_flags ()) ~with_evars:false | _ -> anomaly (Pp.str "elim_scheme_type.") - end } + end let elim_type t = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in let evd, elimc = find_ind_eliminator (fst ind) (Tacticals.New.elimination_sort_of_goal gl) gl in - Sigma.Unsafe.of_pair (elim_scheme_type elimc t, evd) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) (elim_scheme_type elimc t) + end let case_type t = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Tacmach.New.pf_env gl in - let ((ind, u), t) = reduce_to_atomic_ind env (Sigma.to_evar_map sigma) t in - let u = EInstance.kind (Sigma.to_evar_map sigma) u in + let ((ind, u), t) = reduce_to_atomic_ind env sigma t in + let u = EInstance.kind sigma u in let s = Tacticals.New.elimination_sort_of_goal gl in - let Sigma (elimc, evd, p) = build_case_analysis_scheme_default env sigma (ind, u) s in + let (evd, elimc) = build_case_analysis_scheme_default env sigma (ind, u) s in let elimc = EConstr.of_constr elimc in - Sigma (elim_scheme_type elimc t, evd, p) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) (elim_scheme_type elimc t) + end (************************************************) @@ -4745,7 +4700,7 @@ let maybe_betadeltaiota_concl allowred gl = whd_all env sigma concl let reflexivity_red allowred = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> (* PL: usual reflexivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) @@ -4754,7 +4709,7 @@ let reflexivity_red allowred = match match_with_equality_type sigma concl with | None -> Proofview.tclZERO NoEquationFound | Some _ -> one_constructor 1 NoBindings - end } + end let reflexivity = Proofview.tclORELSE @@ -4796,7 +4751,7 @@ let match_with_equation sigma c = Proofview.tclZERO NoEquationFound let symmetry_red allowred = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> (* PL: usual symmetry don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) @@ -4809,7 +4764,7 @@ let symmetry_red allowred = (convert_concl_no_check concl DEFAULTcast) (Tacticals.New.pf_constr_of_global eq_data.sym >>= apply) | None,eq,eq_kind -> prove_symmetry eq eq_kind - end } + end let symmetry = Proofview.tclORELSE @@ -4823,7 +4778,7 @@ let (forward_setoid_symmetry_in, setoid_symmetry_in) = Hook.make () let symmetry_in id = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in let sign,t = decompose_prod_assum sigma ctype in @@ -4843,7 +4798,7 @@ let symmetry_in id = | NoEquationFound -> Hook.get forward_setoid_symmetry_in id | e -> Proofview.tclZERO ~info e end - end } + end let intros_symmetry = Tacticals.New.onClause @@ -4868,7 +4823,7 @@ let (forward_setoid_transitivity, setoid_transitivity) = Hook.make () (* This is probably not very useful any longer *) let prove_transitivity hdcncl eq_kind t = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (eq1,eq2) = match eq_kind with | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |]) @@ -4888,10 +4843,10 @@ let prove_transitivity hdcncl eq_kind t = [ Tacticals.New.tclDO 2 intro; Tacticals.New.onLastHyp simplest_case; assumption ])) - end } + end let transitivity_red allowred t = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> (* PL: usual transitivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) @@ -4909,7 +4864,7 @@ let transitivity_red allowred t = match t with | None -> Tacticals.New.tclZEROMSG (str"etransitivity not supported for this relation.") | Some t -> prove_transitivity eq eq_kind t - end } + end let transitivity_gen t = Proofview.tclORELSE @@ -4994,11 +4949,10 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = let open Tacticals.New in let open Tacmach.New in let open Proofview.Notations in - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let current_sign = Global.named_context_val () and global_sign = Proofview.Goal.hyps gl in - let sigma = Sigma.to_evar_map sigma in let evdref = ref sigma in let sign,secsign = List.fold_right @@ -5065,8 +5019,8 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = tacK lem args in let tac = if not safe then Proofview.mark_as_unsafe <*> solve else solve in - Sigma.Unsafe.of_pair (tac, evd) - end } + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) tac + end let abstract_subproof ~opaque id gk tac = cache_term_by_tactic_then ~opaque id gk tac (fun lem args -> exact_no_check (applist (lem, args))) @@ -5093,7 +5047,7 @@ let tclABSTRACT ?(opaque=true) name_op tac = abstract_subproof ~opaque s gk tac let unify ?(state=full_transparent_state) x y = - Proofview.Goal.s_enter { s_enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in try let core_flags = @@ -5106,12 +5060,11 @@ let unify ?(state=full_transparent_state) x y = merge_unify_flags = core_flags; subterm_unify_flags = { core_flags with modulo_delta = empty_transparent_state } } in - let sigma = Sigma.to_evar_map sigma in let sigma = w_unify (Tacmach.New.pf_env gl) sigma Reduction.CONV ~flags x y in - Sigma.Unsafe.of_pair (Proofview.tclUNIT (), sigma) + Proofview.Unsafe.tclEVARS sigma with e when CErrors.noncritical e -> - Sigma.here (Tacticals.New.tclFAIL 0 (str"Not unifiable")) sigma - end } + Tacticals.New.tclFAIL 0 (str"Not unifiable") + end module Simple = struct (** Simplified version of some of the above tactics *) diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 0dbcce02c..ec8fe1145 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -29,7 +29,7 @@ open Locus (** {6 General functions. } *) -val is_quantified_hypothesis : Id.t -> ('a, 'r) Proofview.Goal.t -> bool +val is_quantified_hypothesis : Id.t -> 'a Proofview.Goal.t -> bool (** {6 Primitive tactics. } *) @@ -75,7 +75,7 @@ val intros : unit Proofview.tactic (** [depth_of_quantified_hypothesis b h g] returns the index of [h] in the conclusion of goal [g], up to head-reduction if [b] is [true] *) val depth_of_quantified_hypothesis : - bool -> quantified_hypothesis -> ('a, 'r) Proofview.Goal.t -> int + bool -> quantified_hypothesis -> 'a Proofview.Goal.t -> int val intros_until : quantified_hypothesis -> unit Proofview.tactic @@ -131,7 +131,7 @@ val exact_proof : Constrexpr.constr_expr -> unit Proofview.tactic type tactic_reduction = env -> evar_map -> constr -> constr -type change_arg = patvar_map -> constr Sigma.run +type change_arg = patvar_map -> evar_map -> evar_map * constr val make_change_arg : constr -> change_arg val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic @@ -211,8 +211,6 @@ val apply_delayed_in : (clear_flag * delayed_open_constr_with_bindings located) list -> intro_pattern option -> unit Proofview.tactic -val run_delayed : Environ.env -> evar_map -> 'a delayed_open -> 'a * evar_map - (** {6 Elimination tactics. } *) (* @@ -437,7 +435,7 @@ end module New : sig - val refine : ?unsafe:bool -> constr Sigma.run -> unit Proofview.tactic + val refine : ?unsafe:bool -> (evar_map -> evar_map * constr) -> unit Proofview.tactic (** [refine ?unsafe c] is [Refine.refine ?unsafe c] followed by beta-iota-reduction of the conclusion. *) diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index b99ccbf4a..9e6e5e313 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -365,7 +365,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = ))) ) in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let type_of_pq = Tacmach.New.pf_unsafe_type_of gl p in let sigma = Tacmach.New.project gl in let u,v = destruct_ind sigma type_of_pq @@ -397,7 +397,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = Tacticals.New.tclTHENLIST [ Proofview.tclEFFECTS eff; Equality.replace p q ; apply app ; Auto.default_auto] - end } + end (* used in the bool -> leib side *) let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = @@ -430,7 +430,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let rec aux l1 l2 = match (l1,l2) with | (t1::q1,t2::q2) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let tt1 = Tacmach.New.pf_unsafe_type_of gl t1 in let sigma = Tacmach.New.project gl in if EConstr.eq_constr sigma t1 t2 then aux q1 q2 @@ -472,7 +472,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = aux q1 q2 ] ) ) - end } + end | ([],[]) -> Proofview.tclUNIT () | _ -> Tacticals.New.tclZEROMSG (str "Both side of the equality must have the same arity.") in @@ -581,7 +581,7 @@ let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec = let fresh = fresh_id_in_env (!avoid) s (Proofview.Goal.env gl) in avoid := fresh::(!avoid); fresh in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in let freshn = fresh_id (Id.of_string "x") gl in let freshm = fresh_id (Id.of_string "y") gl in @@ -604,18 +604,18 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). Tacticals.New.tclREPEAT ( Tacticals.New.tclTHENLIST [ Simple.apply_in freshz (EConstr.of_constr (andb_prop())); - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let fresht = fresh_id (Id.of_string "Z") gl in destruct_on_as (EConstr.mkVar freshz) (IntroOrPattern [[Loc.tag @@ IntroNaming (IntroIdentifier fresht); Loc.tag @@ IntroNaming (IntroIdentifier freshz)]]) - end } + end ]); (* Ci a1 ... an = Ci b1 ... bn replace bi with ai; auto || replace bi with ai by apply typeofbi_prod ; auto *) - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in match EConstr.kind sigma concl with @@ -635,10 +635,10 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). | _ -> Tacticals.New.tclZEROMSG (str" Failure while solving Boolean->Leibniz.") ) | _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") - end } + end ] - end } + end let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined") @@ -725,7 +725,7 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = let fresh = fresh_id_in_env (!avoid) s (Proofview.Goal.env gl) in avoid := fresh::(!avoid); fresh in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in let freshn = fresh_id (Id.of_string "x") gl in let freshm = fresh_id (Id.of_string "y") gl in @@ -748,7 +748,7 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = Tacticals.New.tclTHENLIST [apply (EConstr.of_constr (andb_true_intro())); simplest_split ;Auto.default_auto ] ); - Proofview.Goal.enter { enter = begin fun gls -> + Proofview.Goal.enter begin fun gls -> let concl = Proofview.Goal.concl gls in let sigma = Tacmach.New.project gl in (* assume the goal to be eq (eq_type ...) = true *) @@ -765,9 +765,9 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = ) | _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") - end } + end ] - end } + end let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined") @@ -873,7 +873,7 @@ let compute_dec_tact ind lnamesparrec nparrec = let fresh = fresh_id_in_env (!avoid) s (Proofview.Goal.env gl) in avoid := fresh::(!avoid); fresh in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in let freshn = fresh_id (Id.of_string "x") gl in let freshm = fresh_id (Id.of_string "y") gl in @@ -904,7 +904,7 @@ let compute_dec_tact ind lnamesparrec nparrec = )) (Tacticals.New.tclTHEN (destruct_on (EConstr.of_constr eqbnm)) Auto.default_auto); - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let freshH2 = fresh_id (Id.of_string "H") gl in Tacticals.New.tclTHENS (destruct_on_using (EConstr.mkVar freshH) freshH2) [ (* left *) @@ -916,7 +916,7 @@ let compute_dec_tact ind lnamesparrec nparrec = ; (*right *) - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.enter begin fun gl -> let freshH3 = fresh_id (Id.of_string "H") gl in Tacticals.New.tclTHENLIST [ simplest_right ; @@ -938,11 +938,11 @@ let compute_dec_tact ind lnamesparrec nparrec = true; Equality.discr_tac false None ] - end } + end ] - end } + end ] - end } + end let make_eq_decidability mode mind = let mib = Global.lookup_mind mind in diff --git a/vernac/classes.ml b/vernac/classes.ml index 004083dcf..dc5ce1a53 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -20,7 +20,6 @@ open Libnames open Globnames open Constrintern open Constrexpr -open Sigma.Notations open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration @@ -342,7 +341,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p if not (Option.is_empty term) then let init_refine = Tacticals.New.tclTHENLIST [ - Refine.refine { run = fun evm -> Sigma (EConstr.of_constr (Option.get term), evm, Sigma.refl) }; + Refine.refine (fun evm -> (evm,EConstr.of_constr (Option.get term))); Proofview.Unsafe.tclNEWGOALS gls; Tactics.New.reduce_after_refine; ] diff --git a/vernac/command.ml b/vernac/command.ml index ad84c17b7..b1425d703 100644 --- a/vernac/command.ml +++ b/vernac/command.ml @@ -35,7 +35,6 @@ open Evarconv open Indschemes open Misctypes open Vernacexpr -open Sigma.Notations open Context.Rel.Declaration open Entries @@ -78,8 +77,7 @@ let red_constant_entry n ce sigma = function let env = Global.env () in let (redfun, _) = reduction_of_red_expr env red in let redfun env sigma c = - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (c, _, _) = redfun.e_redfun env sigma c in + let (_, c) = redfun env sigma c in EConstr.Unsafe.to_constr c in { ce with const_entry_body = Future.chain ~pure:true proof_out @@ -908,9 +906,8 @@ let tactics_module = subtac_dir @ ["Tactics"] let init_reference dir s () = Coqlib.coq_reference "Command" dir s let init_constant dir s evdref = - let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map !evdref) - (Coqlib.coq_reference "Command" dir s) - in evdref := Sigma.to_evar_map sigma; c + let (sigma, c) = Evarutil.new_global !evdref (Coqlib.coq_reference "Command" dir s) + in evdref := sigma; c let make_ref l s = init_reference l s let fix_proto = init_constant tactics_module "fix_proto" diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index a678d20bb..c2c27eb78 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -453,13 +453,8 @@ let fold_left' f = function [] -> invalid_arg "fold_left'" | hd :: tl -> List.fold_left f hd tl -let new_global sigma gr = - let open Sigma in - let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map sigma) gr - in Sigma.to_evar_map sigma, c - -let mk_coq_and sigma = new_global sigma (Coqlib.build_coq_and ()) -let mk_coq_conj sigma = new_global sigma (Coqlib.build_coq_conj ()) +let mk_coq_and sigma = Evarutil.new_global sigma (Coqlib.build_coq_and ()) +let mk_coq_conj sigma = Evarutil.new_global sigma (Coqlib.build_coq_conj ()) let build_combined_scheme env schemes = let evdref = ref (Evd.from_env env) in diff --git a/vernac/record.ml b/vernac/record.ml index 8cde88dc9..2400fa681 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -24,7 +24,6 @@ open Type_errors open Constrexpr open Constrexpr_ops open Goptions -open Sigma.Notations open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration @@ -365,15 +364,11 @@ let structure_signature ctx = match l with [] -> Evd.empty | [decl] -> let env = Environ.empty_named_context_val in - let evm = Sigma.Unsafe.of_evar_map evm in - let Sigma (_, evm, _) = Evarutil.new_pure_evar env evm (EConstr.of_constr (RelDecl.get_type decl)) in - let evm = Sigma.to_evar_map evm in + let (evm, _) = Evarutil.new_pure_evar env evm (EConstr.of_constr (RelDecl.get_type decl)) in evm | decl::tl -> let env = Environ.empty_named_context_val in - let evm = Sigma.Unsafe.of_evar_map evm in - let Sigma (ev, evm, _) = Evarutil.new_pure_evar env evm (EConstr.of_constr (RelDecl.get_type decl)) in - let evm = Sigma.to_evar_map evm in + let (evm, ev) = Evarutil.new_pure_evar env evm (EConstr.of_constr (RelDecl.get_type decl)) in let new_tl = Util.List.map_i (fun pos decl -> RelDecl.map_type (fun t -> EConstr.Unsafe.to_constr (Termops.replace_term evm (EConstr.mkRel pos) (EConstr.mkEvar(ev,[||])) (EConstr.of_constr t))) decl) 1 tl in diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index c6ec89c5e..1332a7052 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -31,7 +31,6 @@ open Redexpr open Lemmas open Misctypes open Locality -open Sigma.Notations module NamedDecl = Context.Named.Declaration @@ -1550,8 +1549,7 @@ let vernac_check_may_eval ?loc redexp glopt rc = let (sigma',r_interp) = Hook.get f_interp_redexp env sigma' r in let redfun env evm c = let (redfun, _) = reduction_of_red_expr env r_interp in - let evm = Sigma.Unsafe.of_evar_map evm in - let Sigma (c, _, _) = redfun.Reductionops.e_redfun env evm c in + let (_, c) = redfun env evm c in c in Feedback.msg_notice (print_eval redfun env sigma' rc j) |