aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEmilio Jesus Gallego Arias2019-05-01 08:28:57 +0200
committerEmilio Jesus Gallego Arias2019-05-01 18:49:02 +0200
commitba5ea9fb6aaa3faace0960adca4d41fc74cb2ac7 (patch)
treeab14d96954dce28fd46a32960c446f068ccae9f0
parent213b5419136e4639f345e171c086b154c14aa62c (diff)
[comDefinition] Use prepare function from DeclareDef.
We also update the plugin tutorial. This was already tried [in the same exact way] in #8811, however the bench time was not convincing then, but now things seem a bit better, likely due to the removal of some extra normalization somewhere. Some more changes from #8811 are still pending.
-rw-r--r--doc/plugin_tutorial/tuto1/src/simple_declare.ml13
-rw-r--r--vernac/comDefinition.ml31
2 files changed, 12 insertions, 32 deletions
diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml
index 23f8fbe888..3c0355c92d 100644
--- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml
+++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml
@@ -1,17 +1,8 @@
-(* Ideally coq/coq#8811 would get merged and then this function could be much simpler. *)
let edeclare ?hook ~ontop ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps =
- let sigma = Evd.minimize_universes sigma in
- let body = EConstr.to_constr sigma body in
- let tyopt = Option.map (EConstr.to_constr sigma) tyopt in
- let uvars_fold uvars c =
- Univ.LSet.union uvars (Vars.universes_of_constr c) in
- let uvars = List.fold_left uvars_fold Univ.LSet.empty
- (Option.List.cons tyopt [body]) in
- let sigma = Evd.restrict_universe_context sigma uvars in
- let univs = Evd.check_univ_decl ~poly sigma udecl in
+ let sigma, ce = DeclareDef.prepare_definition ~allow_evars:false
+ ~opaque ~poly sigma udecl ~types:tyopt ~body in
let uctx = Evd.evar_universe_context sigma in
let ubinders = Evd.universe_binders sigma in
- let ce = Declare.definition_entry ?types:tyopt ~univs body in
let hook_data = Option.map (fun hook -> hook, uctx, []) hook in
DeclareDef.declare_definition ~ontop ident k ce ubinders imps ?hook_data
diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml
index feaf47df18..12df3215ad 100644
--- a/vernac/comDefinition.ml
+++ b/vernac/comDefinition.ml
@@ -12,7 +12,6 @@ open Pp
open Util
open Entries
open Redexpr
-open Declare
open Constrintern
open Pretyping
@@ -42,10 +41,9 @@ let check_imps ~impsty ~impsbody =
if not b then warn_implicits_in_term ()
let interp_definition ~program_mode pl bl poly red_option c ctypopt =
- let open EConstr in
let env = Global.env() in
(* Explicitly bound universes and constraints *)
- let evd, decl = Constrexpr_ops.interp_univ_decl_opt env pl in
+ let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env pl in
(* Build the parameters *)
let evd, (impls, ((env_bl, ctx), imps1)) = interp_context_evars ~program_mode env evd bl in
(* Build the type *)
@@ -66,24 +64,15 @@ let interp_definition ~program_mode pl bl poly red_option c ctypopt =
in
(* Do the reduction *)
let evd, c = red_constant_body red_option env_bl evd c in
- (* universe minimization *)
- let evd = Evd.minimize_universes evd in
- (* Substitute evars and universes, and add parameters.
- Note: in program mode some evars may remain. *)
- let ctx = List.map Termops.(map_rel_decl (to_constr ~abort_on_undefined_evars:false evd)) ctx in
- let c = Term.it_mkLambda_or_LetIn (EConstr.to_constr ~abort_on_undefined_evars:false evd c) ctx in
- let tyopt = Option.map (fun ty -> Term.it_mkProd_or_LetIn (EConstr.to_constr ~abort_on_undefined_evars:false evd ty) ctx) tyopt in
- (* Keep only useful universes. *)
- let uvars_fold uvars c =
- Univ.LSet.union uvars (universes_of_constr evd (of_constr c))
- in
- let uvars = List.fold_left uvars_fold Univ.LSet.empty (Option.List.cons tyopt [c]) in
- let evd = Evd.restrict_universe_context evd uvars in
- (* Check we conform to declared universes *)
- let uctx = Evd.check_univ_decl ~poly evd decl in
- (* We're done! *)
- let ce = definition_entry ?types:tyopt ~univs:uctx c in
- (ce, evd, decl, imps)
+
+ (* Declare the definition *)
+ let c = EConstr.it_mkLambda_or_LetIn c ctx in
+ let tyopt = Option.map (fun ty -> EConstr.it_mkProd_or_LetIn ty ctx) tyopt in
+
+ let evd, ce = DeclareDef.prepare_definition ~allow_evars:program_mode
+ ~opaque:false ~poly evd udecl ~types:tyopt ~body:c in
+
+ (ce, evd, udecl, imps)
let check_definition ~program_mode (ce, evd, _, imps) =
let env = Global.env () in