diff options
Diffstat (limited to 'vernac/obligations.ml')
| -rw-r--r-- | vernac/obligations.ml | 44 |
1 files changed, 26 insertions, 18 deletions
diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 1885fc38e..8843e52f4 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -259,14 +259,16 @@ let eterm_obligations env name evm fs ?status t ty = let tactics_module = ["Program";"Tactics"] let safe_init_constant md name () = Coqlib.check_required_library ("Coq"::md); - Universes.constr_of_global (Coqlib.coq_reference "Obligations" md name) + UnivGen.constr_of_global (Coqlib.coq_reference "Obligations" md name) let hide_obligation = safe_init_constant tactics_module "obligation" let pperror cmd = CErrors.user_err ~hdr:"Program" cmd let error s = pperror (str s) let reduce c = - EConstr.Unsafe.to_constr (Reductionops.clos_norm_flags CClosure.betaiota (Global.env ()) Evd.empty (EConstr.of_constr c)) + let env = Global.env () in + let sigma = Evd.from_env env in + EConstr.Unsafe.to_constr (Reductionops.clos_norm_flags CClosure.betaiota env sigma (EConstr.of_constr c)) exception NoObligations of Id.t option @@ -306,7 +308,7 @@ type program_info_aux = { prg_body: constr; prg_type: constr; prg_ctx: UState.t; - prg_univdecl: Univdecls.universe_decl; + prg_univdecl: UState.universe_decl; prg_obligations: obligations; prg_deps : Id.t list; prg_fixkind : fixpoint_kind option ; @@ -472,7 +474,7 @@ let subst_body expand prg = let declare_definition prg = let body, typ = subst_body true prg in - let nf = Universes.nf_evars_and_universes_opt_subst (fun x -> None) + let nf = UnivSubst.nf_evars_and_universes_opt_subst (fun x -> None) (UState.subst prg.prg_ctx) in let opaque = prg.prg_opaque in let fix_exn = Hook.get get_fix_exn () in @@ -521,8 +523,10 @@ let declare_mutual_definition l = List.split3 (List.map (fun x -> let subs, typ = (subst_body true x) in - let term = snd (Reductionops.splay_lam_n (Global.env ()) Evd.empty len (EConstr.of_constr subs)) in - let typ = snd (Reductionops.splay_prod_n (Global.env ()) Evd.empty len (EConstr.of_constr typ)) in + let env = Global.env () in + let sigma = Evd.from_env env in + let term = snd (Reductionops.splay_lam_n env sigma len (EConstr.of_constr subs)) in + let typ = snd (Reductionops.splay_prod_n env sigma len (EConstr.of_constr typ)) in let term = EConstr.Unsafe.to_constr term in let typ = EConstr.Unsafe.to_constr typ in x.prg_reduce term, x.prg_reduce typ, x.prg_implicits) l) @@ -555,7 +559,7 @@ let declare_mutual_definition l = (* Declare the recursive definitions *) let univs = UState.const_univ_entry ~poly first.prg_ctx in let fix_exn = Hook.get get_fix_exn () in - let kns = List.map4 (DeclareDef.declare_fix ~opaque (local, poly, kind) Universes.empty_binders univs) + let kns = List.map4 (DeclareDef.declare_fix ~opaque (local, poly, kind) UnivNames.empty_binders univs) fixnames fixdecls fixtypes fiximps in (* Declare notations *) List.iter (Metasyntax.add_notation_interpretation (Global.env())) first.prg_notations; @@ -612,7 +616,7 @@ let shrink_body c ty = let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst] let add_hint local prg cst = - Hints.add_hints local [Id.to_string prg.prg_name] (unfold_entry cst) + Hints.add_hints ~local [Id.to_string prg.prg_name] (unfold_entry cst) let it_mkLambda_or_LetIn_or_clean t ctx = let open Context.Rel.Declaration in @@ -849,12 +853,12 @@ let obligation_terminator name num guard hook auto pf = let obl = obls.(num) in let status = match obl.obl_status, opq with - | (_, Evar_kinds.Expand), Vernacexpr.Opaque -> err_not_transp () - | (true, _), Vernacexpr.Opaque -> err_not_transp () - | (false, _), Vernacexpr.Opaque -> Evar_kinds.Define true - | (_, Evar_kinds.Define true), Vernacexpr.Transparent -> + | (_, Evar_kinds.Expand), Opaque -> err_not_transp () + | (true, _), Opaque -> err_not_transp () + | (false, _), Opaque -> Evar_kinds.Define true + | (_, Evar_kinds.Define true), Transparent -> Evar_kinds.Define false - | (_, status), Vernacexpr.Transparent -> status + | (_, status), Transparent -> status in let obl = { obl with obl_status = false, status } in let ctx = @@ -1069,9 +1073,11 @@ let show_obligations_of_prg ?(msg=true) prg = if !showed > 0 then ( decr showed; let x = subst_deps_obl obls x in + let env = Global.env () in + let sigma = Evd.from_env env in Feedback.msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ str "of" ++ spc() ++ Id.print n ++ str ":" ++ spc () ++ - hov 1 (Printer.pr_constr_env (Global.env ()) Evd.empty x.obl_type ++ + hov 1 (Printer.pr_constr_env env sigma x.obl_type ++ str "." ++ fnl ()))) | Some _ -> ()) obls @@ -1087,11 +1093,13 @@ let show_obligations ?(msg=true) n = let show_term n = let prg = get_prog_err n in let n = prg.prg_name in + let env = Global.env () in + let sigma = Evd.from_env env in (Id.print n ++ spc () ++ str":" ++ spc () ++ - Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_type ++ spc () ++ str ":=" ++ fnl () - ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_body) + Printer.pr_constr_env env sigma prg.prg_type ++ spc () ++ str ":=" ++ fnl () + ++ Printer.pr_constr_env env sigma prg.prg_body) -let add_definition n ?term t ctx ?(univdecl=Univdecls.default_univ_decl) +let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl) ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) obls = let sign = Decls.initialize_named_context_for_proof () in @@ -1111,7 +1119,7 @@ let add_definition n ?term t ctx ?(univdecl=Univdecls.default_univ_decl) | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res | _ -> res) -let add_mutual_definitions l ctx ?(univdecl=Univdecls.default_univ_decl) ?tactic +let add_mutual_definitions l ctx ?(univdecl=UState.default_univ_decl) ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) notations fixkind = let sign = Decls.initialize_named_context_for_proof () in |