diff options
Diffstat (limited to 'plugins/funind')
| -rw-r--r-- | plugins/funind/functional_principles_proofs.ml | 14 | ||||
| -rw-r--r-- | plugins/funind/gen_principle.ml | 43 | ||||
| -rw-r--r-- | plugins/funind/gen_principle.mli | 2 | ||||
| -rw-r--r-- | plugins/funind/recdef.ml | 68 | ||||
| -rw-r--r-- | plugins/funind/recdef.mli | 2 |
5 files changed, 73 insertions, 56 deletions
diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index b864b18887..2151ad7873 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -853,12 +853,16 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num (*i The next call to mk_equation_id is valid since we are constructing the lemma Ensures by: obvious i*) - let lemma = - Lemmas.start_lemma ~name:(mk_equation_id f_id) ~poly:false evd lemma_type + let info = Declare.Info.make () in + let cinfo = + Declare.CInfo.make ~name:(mk_equation_id f_id) ~typ:lemma_type () + in + let lemma = Declare.Proof.start ~cinfo ~info evd in + let lemma, _ = + Declare.Proof.by (Proofview.V82.tactic prove_replacement) lemma in - let lemma, _ = Lemmas.by (Proofview.V82.tactic prove_replacement) lemma in - let () = - Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent ~idopt:None + let (_ : _ list) = + Declare.Proof.save ~proof:lemma ~opaque:Vernacexpr.Transparent ~idopt:None in evd diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 608155eb71..167cf37026 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -319,7 +319,7 @@ let generate_functional_principle (evd : Evd.evar_map ref) old_princ_type sorts let entry = Declare.definition_entry ~univs ?types body in let (_ : Names.GlobRef.t) = Declare.declare_entry ~name:new_princ_name ~hook - ~scope:(Declare.Global Declare.ImportDefaultBehavior) + ~scope:(Locality.Global Locality.ImportDefaultBehavior) ~kind:Decls.(IsProof Theorem) ~impargs:[] ~uctx entry in @@ -400,7 +400,7 @@ let register_struct is_rec fixpoint_exprl = Pp.(str "Body of Function must be given") in ComDefinition.do_definition ~name:fname.CAst.v ~poly:false - ~scope:(Declare.Global Declare.ImportDefaultBehavior) + ~scope:(Locality.Global Locality.ImportDefaultBehavior) ~kind:Decls.Definition univs binders None body (Some rtype); let evd, rev_pconstants = List.fold_left @@ -419,7 +419,7 @@ let register_struct is_rec fixpoint_exprl = (None, evd, List.rev rev_pconstants) | _ -> ComFixpoint.do_fixpoint - ~scope:(Declare.Global Declare.ImportDefaultBehavior) ~poly:false + ~scope:(Locality.Global Locality.ImportDefaultBehavior) ~poly:false fixpoint_exprl; let evd, rev_pconstants = List.fold_left @@ -1370,12 +1370,12 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : _ list = | None -> raise Not_found | Some finfos -> finfos in - let open Declare in match finfos.equation_lemma with - | None -> Transparent (* non recursive definition *) + | None -> Vernacexpr.Transparent (* non recursive definition *) | Some equation -> - if Declareops.is_opaque (Global.lookup_constant equation) then Opaque - else Transparent + if Declareops.is_opaque (Global.lookup_constant equation) then + Vernacexpr.Opaque + else Vernacexpr.Transparent in let body, typ, univs, _hook, sigma0 = try @@ -1518,12 +1518,14 @@ let derive_correctness (funs : Constr.pconstant list) (graphs : inductive list) i*) let lem_id = mk_correct_id f_id in let typ, _ = lemmas_types_infos.(i) in - let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false !evd typ in + let info = Declare.Info.make () in + let cinfo = Declare.CInfo.make ~name:lem_id ~typ () in + let lemma = Declare.Proof.start ~cinfo ~info !evd in let lemma = - fst @@ Lemmas.by (Proofview.V82.tactic (proving_tac i)) lemma + fst @@ Declare.Proof.by (Proofview.V82.tactic (proving_tac i)) lemma in - let () = - Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent + let (_ : GlobRef.t list) = + Declare.Proof.save ~proof:lemma ~opaque:Vernacexpr.Transparent ~idopt:None in let finfo = @@ -1580,21 +1582,22 @@ let derive_correctness (funs : Constr.pconstant list) (graphs : inductive list) Ensures by: obvious i*) let lem_id = mk_complete_id f_id in - let lemma = - Lemmas.start_lemma ~name:lem_id ~poly:false sigma - (fst lemmas_types_infos.(i)) + let info = Declare.Info.make () in + let cinfo = + Declare.CInfo.make ~name:lem_id ~typ:(fst lemmas_types_infos.(i)) () in + let lemma = Declare.Proof.start ~cinfo sigma ~info in let lemma = fst - (Lemmas.by + (Declare.Proof.by (Proofview.V82.tactic (observe_tac ("prove completeness (" ^ Id.to_string f_id ^ ")") (proving_tac i))) lemma) in - let () = - Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent + let (_ : _ list) = + Declare.Proof.save ~proof:lemma ~opaque:Vernacexpr.Transparent ~idopt:None in let finfo = @@ -1769,7 +1772,7 @@ let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt using_lemmas args ret_type body let do_generate_principle_aux pconstants on_error register_built - interactive_proof fixpoint_exprl : Lemmas.t option = + interactive_proof fixpoint_exprl : Declare.Proof.t option = List.iter (fun {Vernacexpr.notations} -> if not (List.is_empty notations) then @@ -2155,7 +2158,7 @@ let make_graph (f_ref : GlobRef.t) = (* *************** statically typed entrypoints ************************* *) -let do_generate_principle_interactive fixl : Lemmas.t = +let do_generate_principle_interactive fixl : Declare.Proof.t = match do_generate_principle_aux [] warning_error true true fixl with | Some lemma -> lemma | None -> @@ -2199,7 +2202,7 @@ let build_scheme fas = List.iter2 (fun (princ_id, _, _) (body, types, univs, opaque) -> let (_ : Constant.t) = - let opaque = if opaque = Declare.Opaque then true else false in + let opaque = if opaque = Vernacexpr.Opaque then true else false in let def_entry = Declare.definition_entry ~univs ~opaque ?types body in Declare.declare_constant ~name:princ_id ~kind:Decls.(IsProof Theorem) diff --git a/plugins/funind/gen_principle.mli b/plugins/funind/gen_principle.mli index 3c04d6cb7d..28751c4501 100644 --- a/plugins/funind/gen_principle.mli +++ b/plugins/funind/gen_principle.mli @@ -12,7 +12,7 @@ val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit val do_generate_principle_interactive : - Vernacexpr.fixpoint_expr list -> Lemmas.t + Vernacexpr.fixpoint_expr list -> Declare.Proof.t val do_generate_principle : Vernacexpr.fixpoint_expr list -> unit val make_graph : Names.GlobRef.t -> unit diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 9b2d9c4815..884792cc15 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -58,7 +58,10 @@ let declare_fun name kind ?univs value = (Declare.declare_constant ~name ~kind (Declare.DefinitionEntry ce)) let defined lemma = - Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent ~idopt:None + let (_ : _ list) = + Declare.Proof.save ~proof:lemma ~opaque:Vernacexpr.Transparent ~idopt:None + in + () let def_of_const t = match Constr.kind t with @@ -1343,7 +1346,7 @@ let whole_start concl_tac nb_args is_mes func input_type relation rec_arg_num : g let get_current_subgoals_types pstate = - let p = Declare.Proof.get_proof pstate in + let p = Declare.Proof.get pstate in let Proof.{goals = sgs; sigma; _} = Proof.data p in (sigma, List.map (Goal.V82.abstract_type sigma) sgs) @@ -1405,7 +1408,7 @@ let clear_goals sigma = List.map clear_goal let build_new_goal_type lemma = - let sigma, sub_gls_types = Lemmas.pf_fold get_current_subgoals_types lemma in + let sigma, sub_gls_types = get_current_subgoals_types lemma in (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let sub_gls_types = clear_goals sigma sub_gls_types in (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) @@ -1414,16 +1417,17 @@ let build_new_goal_type lemma = let is_opaque_constant c = let cb = Global.lookup_constant c in + let open Vernacexpr in match cb.Declarations.const_body with - | Declarations.OpaqueDef _ -> Declare.Opaque - | Declarations.Undef _ -> Declare.Opaque - | Declarations.Def _ -> Declare.Transparent - | Declarations.Primitive _ -> Declare.Opaque + | Declarations.OpaqueDef _ -> Opaque + | Declarations.Undef _ -> Opaque + | Declarations.Def _ -> Transparent + | Declarations.Primitive _ -> Opaque let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type, decompose_and_tac, nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) - let current_proof_name = Lemmas.pf_fold Declare.Proof.get_proof_name lemma in + let current_proof_name = Declare.Proof.get_name lemma in let name = match goal_name with | Some s -> s @@ -1488,18 +1492,20 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name [Hints.Hint_db.empty TransparentState.empty false] ])) in let lemma = build_proof env (Evd.from_env env) start_tac end_tac in - Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None - in - let info = Lemmas.Info.make ~hook:(Declare.Hook.make hook) () in - let lemma = - Lemmas.start_lemma ~name:na ~poly:false (* FIXME *) ~info sigma gls_type + let (_ : _ list) = + Declare.Proof.save ~proof:lemma ~opaque:opacity ~idopt:None + in + () in + let info = Declare.Info.make ~hook:(Declare.Hook.make hook) () in + let cinfo = Declare.CInfo.make ~name:na ~typ:gls_type () in + let lemma = Declare.Proof.start ~cinfo ~info sigma in let lemma = if Indfun_common.is_strict_tcc () then - fst @@ Lemmas.by (Proofview.V82.tactic tclIDTAC) lemma + fst @@ Declare.Proof.by (Proofview.V82.tactic tclIDTAC) lemma else fst - @@ Lemmas.by + @@ Declare.Proof.by (Proofview.V82.tactic (fun g -> tclTHEN decompose_and_tac (tclORELSE @@ -1521,27 +1527,28 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name g)) lemma in - if Lemmas.(pf_fold Declare.Proof.get_open_goals) lemma = 0 then ( - defined lemma; None ) + if Declare.Proof.get_open_goals lemma = 0 then (defined lemma; None) else Some lemma let com_terminate interactive_proof tcc_lemma_name tcc_lemma_ref is_mes fonctional_ref input_type relation rec_arg_num thm_name using_lemmas nb_args ctx hook = let start_proof env ctx tac_start tac_end = - let info = Lemmas.Info.make ~hook () in - let lemma = - Lemmas.start_lemma ~name:thm_name ~poly:false (*FIXME*) ~info ctx - (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) + let cinfo = + Declare.CInfo.make ~name:thm_name + ~typ:(EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) + () in + let info = Declare.Info.make ~hook () in + let lemma = Declare.Proof.start ~cinfo ~info ctx in let lemma = fst - @@ Lemmas.by + @@ Declare.Proof.by (New.observe_tac (fun _ _ -> str "starting_tac") tac_start) lemma in fst - @@ Lemmas.by + @@ Declare.Proof.by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "whole_start") @@ -1602,13 +1609,16 @@ let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref let evd = Evd.from_ctx uctx in let f_constr = constr_of_monomorphic_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in - let lemma = - Lemmas.start_lemma ~name:eq_name ~poly:false evd - (EConstr.of_constr equation_lemma_type) + let info = Declare.Info.make () in + let cinfo = + Declare.CInfo.make ~name:eq_name + ~typ:(EConstr.of_constr equation_lemma_type) + () in + let lemma = Declare.Proof.start ~cinfo evd ~info in let lemma = fst - @@ Lemmas.by + @@ Declare.Proof.by (Proofview.V82.tactic (start_equation f_ref terminate_ref (fun x -> prove_eq @@ -1642,7 +1652,7 @@ let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref in let _ = Flags.silently - (fun () -> Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None) + (fun () -> Declare.Proof.save ~proof:lemma ~opaque:opacity ~idopt:None) () in () @@ -1651,7 +1661,7 @@ let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : - Lemmas.t option = + Declare.Proof.t option = let open Term in let open Constr in let open CVars in diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index 4e5146e37c..2612f2b63e 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -25,4 +25,4 @@ val recursive_definition : -> EConstr.constr -> unit) -> Constrexpr.constr_expr list - -> Lemmas.t option + -> Declare.Proof.t option |