From 1bf2a088387949c13602997d181e6f7d0f014b3f Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Sun, 5 May 2019 16:32:17 +0200 Subject: rewrite.ml: drop the id returned by new_instance earlier We never use this id in rewrite.ml so don't bother threading it around. --- plugins/ltac/rewrite.ml | 90 +++++++++++++++++++++++++------------------------ 1 file changed, 46 insertions(+), 44 deletions(-) diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 164bd7e118..950115146b 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1797,9 +1797,11 @@ let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance ~pstate atts binders (name,t) fields = let program_mode = atts.program in - new_instance ~pstate ~program_mode atts.polymorphic - name binders t (Some (true, CAst.make @@ CRecord (fields))) - ~global:atts.global ~generalize:false Hints.empty_hint_info + let _id, pstate = new_instance ~pstate ~program_mode atts.polymorphic + name binders t (Some (true, CAst.make @@ CRecord (fields))) + ~global:atts.global ~generalize:false Hints.empty_hint_info + in + pstate let declare_instance_refl ~pstate atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" @@ -1819,41 +1821,41 @@ let declare_instance_trans atts binders a aeq n lemma = let declare_relation ~pstate atts ?(binders=[]) a aeq n refl symm trans = init_setoid (); let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" in - let _, pstate = anew_instance ~pstate atts binders instance [] in + let pstate = anew_instance ~pstate atts binders instance [] in match (refl,symm,trans) with - (None, None, None) -> pstate - | (Some lemma1, None, None) -> - snd @@ declare_instance_refl ~pstate atts binders a aeq n lemma1 - | (None, Some lemma2, None) -> - snd @@ declare_instance_sym ~pstate atts binders a aeq n lemma2 - | (None, None, Some lemma3) -> - snd @@ declare_instance_trans ~pstate atts binders a aeq n lemma3 - | (Some lemma1, Some lemma2, None) -> - let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in - snd @@ declare_instance_sym ~pstate atts binders a aeq n lemma2 - | (Some lemma1, None, Some lemma3) -> - let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in - let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in - snd @@ anew_instance ~pstate atts binders instance - [(qualid_of_ident (Id.of_string "PreOrder_Reflexive"), lemma1); - (qualid_of_ident (Id.of_string "PreOrder_Transitive"),lemma3)] - | (None, Some lemma2, Some lemma3) -> - let _lemma_sym, pstate = declare_instance_sym ~pstate atts binders a aeq n lemma2 in - let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in - snd @@ anew_instance ~pstate atts binders instance - [(qualid_of_ident (Id.of_string "PER_Symmetric"), lemma2); - (qualid_of_ident (Id.of_string "PER_Transitive"),lemma3)] - | (Some lemma1, Some lemma2, Some lemma3) -> - let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in - let _lemma_sym, pstate = declare_instance_sym ~pstate atts binders a aeq n lemma2 in - let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in - snd @@ anew_instance ~pstate atts binders instance - [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), lemma1); - (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), lemma2); - (qualid_of_ident (Id.of_string "Equivalence_Transitive"), lemma3)] + (None, None, None) -> pstate + | (Some lemma1, None, None) -> + declare_instance_refl ~pstate atts binders a aeq n lemma1 + | (None, Some lemma2, None) -> + declare_instance_sym ~pstate atts binders a aeq n lemma2 + | (None, None, Some lemma3) -> + declare_instance_trans ~pstate atts binders a aeq n lemma3 + | (Some lemma1, Some lemma2, None) -> + let pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in + declare_instance_sym ~pstate atts binders a aeq n lemma2 + | (Some lemma1, None, Some lemma3) -> + let pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in + let pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in + anew_instance ~pstate atts binders instance + [(qualid_of_ident (Id.of_string "PreOrder_Reflexive"), lemma1); + (qualid_of_ident (Id.of_string "PreOrder_Transitive"),lemma3)] + | (None, Some lemma2, Some lemma3) -> + let pstate = declare_instance_sym ~pstate atts binders a aeq n lemma2 in + let pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in + anew_instance ~pstate atts binders instance + [(qualid_of_ident (Id.of_string "PER_Symmetric"), lemma2); + (qualid_of_ident (Id.of_string "PER_Transitive"),lemma3)] + | (Some lemma1, Some lemma2, Some lemma3) -> + let pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in + let pstate = declare_instance_sym ~pstate atts binders a aeq n lemma2 in + let pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in + anew_instance ~pstate atts binders instance + [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), lemma1); + (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), lemma2); + (qualid_of_ident (Id.of_string "Equivalence_Transitive"), lemma3)] let cHole = CAst.make @@ CHole (None, Namegen.IntroAnonymous, None) @@ -1952,15 +1954,15 @@ let warn_add_setoid_deprecated = let add_setoid ~pstate atts binders a aeq t n = warn_add_setoid_deprecated ?loc:a.CAst.loc (); init_setoid (); - let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in - let _lemma_sym, pstate = declare_instance_sym ~pstate atts binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in - let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in + let pstate = declare_instance_refl ~pstate atts binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in + let pstate = declare_instance_sym ~pstate atts binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in + let pstate = declare_instance_trans ~pstate atts binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in - snd @@ anew_instance ~pstate atts binders instance - [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); - (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); - (qualid_of_ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])] + anew_instance ~pstate atts binders instance + [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); + (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); + (qualid_of_ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])] let make_tactic name = -- cgit v1.2.3 From 33b18aaffd999fb6d31fd5e9c7ca4426d5186983 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Sun, 5 May 2019 16:42:36 +0200 Subject: instance_name grammar entry isn't global Not needed since we don't allow anonymous Declare Instance anymore (was needed for factorization or some such before that I think) --- vernac/g_vernac.mlg | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 5eec8aed1e..63e6dd247f 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -50,7 +50,6 @@ let def_body = Entry.create "vernac:def_body" let decl_notation = Entry.create "vernac:decl_notation" let record_field = Entry.create "vernac:record_field" let of_type_with_opt_coercion = Entry.create "vernac:of_type_with_opt_coercion" -let instance_name = Entry.create "vernac:instance_name" let section_subset_expr = Entry.create "vernac:section_subset_expr" let make_bullet s = @@ -683,7 +682,7 @@ END (* Extensions: implicits, coercions, etc. *) GRAMMAR EXTEND Gram - GLOBAL: gallina_ext instance_name hint_info; + GLOBAL: gallina_ext hint_info; gallina_ext: [ [ (* Transparent and Opaque *) -- cgit v1.2.3 From 1c228b648cb1755cad3ec1f38690110d6fe14bc5 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Sun, 5 May 2019 16:58:10 +0200 Subject: rewrite.ml: remove outdated comment --- plugins/ltac/rewrite.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 950115146b..6f84e6c18d 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1977,7 +1977,6 @@ let warn_add_morphism_deprecated = let add_morphism_infer ~pstate atts m n : Proof_global.t option = warn_add_morphism_deprecated ?loc:m.CAst.loc (); init_setoid (); - (* NB: atts.program is ignored, program mode automatically set by vernacentries *) let instance_id = add_suffix n "_Proper" in let env = Global.env () in let evd = Evd.from_env env in -- cgit v1.2.3 From 8abacf00c6c39ec98085d531737d18edc9c19b2a Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Thu, 2 May 2019 19:46:02 +0200 Subject: Proof_global: pass only 1 pstate when we don't want the proof stack Typically instead of [start_proof : ontop:Proof_global.t option -> bla -> Proof_global.t] we have [start_proof : bla -> Proof_global.pstate] and the pstate is pushed on the stack by a caller around the vernacentries/mlg level. Naming can be a bit awkward, hopefully it can be improved (maybe in a followup PR). We can see some patterns appear waiting for nicer combinators, eg in mlg we often only want to work with the current proof, not the stack. Behaviour should be similar modulo bugs, let's see what CI says. --- doc/plugin_tutorial/tuto1/src/g_tuto1.mlg | 9 +- ide/idetop.ml | 1 + plugins/derive/derive.ml | 4 +- plugins/derive/derive.mli | 2 +- plugins/derive/g_derive.mlg | 2 +- plugins/extraction/extract_env.ml | 4 - plugins/extraction/extract_env.mli | 2 +- plugins/extraction/g_extraction.mlg | 8 +- plugins/funind/functional_principles_proofs.ml | 9 +- plugins/funind/functional_principles_types.ml | 11 +- plugins/funind/g_indfun.mlg | 18 ++-- plugins/funind/indfun.ml | 31 +++--- plugins/funind/indfun.mli | 6 +- plugins/funind/invfun.ml | 8 +- plugins/funind/recdef.ml | 20 ++-- plugins/funind/recdef.mli | 4 +- plugins/ltac/extratactics.mlg | 2 +- plugins/ltac/g_obligations.mlg | 4 +- plugins/ltac/g_rewrite.mlg | 3 +- plugins/ltac/rewrite.ml | 6 +- plugins/ltac/rewrite.mli | 2 +- proofs/pfedit.ml | 4 +- proofs/pfedit.mli | 8 +- proofs/proof_global.ml | 90 ++++++++++------- proofs/proof_global.mli | 55 ++++++---- stm/proofBlockDelimiter.ml | 1 + stm/stm.ml | 4 +- tactics/hints.mli | 2 +- user-contrib/Ltac2/g_ltac2.mlg | 2 +- user-contrib/Ltac2/tac2entries.mli | 2 +- vernac/classes.ml | 135 +++++++++++++------------ vernac/classes.mli | 14 --- vernac/comFixpoint.ml | 16 +-- vernac/comFixpoint.mli | 12 +-- vernac/lemmas.ml | 30 +++--- vernac/lemmas.mli | 21 ++-- vernac/obligations.ml | 14 +-- vernac/obligations.mli | 10 +- vernac/search.mli | 12 +-- vernac/vernacentries.ml | 88 +++++++++------- vernac/vernacstate.ml | 24 +++-- 41 files changed, 385 insertions(+), 315 deletions(-) diff --git a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg index 75251d8e33..147b0df567 100644 --- a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg +++ b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg @@ -146,11 +146,12 @@ END VERNAC COMMAND EXTEND ExploreProof CLASSIFIED AS QUERY | ![ proof ] [ "Cmd9" ] -> - { fun ~pstate -> - Option.iter (fun (pstate : Proof_global.t) -> + { fun ~pstate:ontop -> + Option.iter (fun ontop -> + let pstate = Proof_global.get_current_pstate ontop in let sigma, env = Pfedit.get_current_context pstate in let pprf = Proof.partial_proof Proof_global.(give_me_the_proof pstate) in Feedback.msg_notice - (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf)) pstate; - pstate } + (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf)) ontop; + ontop } END diff --git a/ide/idetop.ml b/ide/idetop.ml index 970d7cf650..90bd2f314d 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -340,6 +340,7 @@ let import_search_constraint = function let search flags = let pstate = Vernacstate.Proof_global.get () in + let pstate = Option.map Proof_global.get_current_pstate pstate in List.map export_coq_object (Search.interface_search ?pstate ( List.map (fun (c, b) -> (import_search_constraint c, b)) flags) ) diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 4769c2dc53..9c1882dc9a 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -101,8 +101,8 @@ let start_deriving f suchthat lemma = in let terminator = Proof_global.make_terminator terminator in - let pstate = Proof_global.start_dependent_proof ~ontop:None lemma kind goals terminator in - Proof_global.simple_with_current_proof begin fun _ p -> + let pstate = Proof_global.start_dependent_proof lemma kind goals terminator in + Proof_global.modify_proof begin fun p -> let p,_,() = Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p in p end pstate diff --git a/plugins/derive/derive.mli b/plugins/derive/derive.mli index 6bb923118e..6e4bffa0b6 100644 --- a/plugins/derive/derive.mli +++ b/plugins/derive/derive.mli @@ -12,4 +12,4 @@ (which can contain references to [f]) in the context extended by [f:=?x]. When the proof ends, [f] is defined as the value of [?x] and [lemma] as the proof. *) -val start_deriving : Names.Id.t -> Constrexpr.constr_expr -> Names.Id.t -> Proof_global.t +val start_deriving : Names.Id.t -> Constrexpr.constr_expr -> Names.Id.t -> Proof_global.pstate diff --git a/plugins/derive/g_derive.mlg b/plugins/derive/g_derive.mlg index 214a9d8bb5..ee076f5ae3 100644 --- a/plugins/derive/g_derive.mlg +++ b/plugins/derive/g_derive.mlg @@ -24,5 +24,5 @@ let classify_derive_command _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpac VERNAC COMMAND EXTEND Derive CLASSIFIED BY { classify_derive_command } | ![ proof ] [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> - { fun ~pstate -> Some Derive.(start_deriving f suchthat lemma) } + { fun ~pstate -> Some (Proof_global.push ~ontop:pstate Derive.(start_deriving f suchthat lemma)) } END diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 8f17f7b2dd..c5439ffaf6 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -751,10 +751,6 @@ let extract_and_compile l = (* Show the extraction of the current ongoing proof *) let show_extraction ~pstate = - let pstate = match pstate with - | None -> CErrors.user_err Pp.(str "No ongoing proof") - | Some pstate -> pstate - in init ~inner:true false false; let prf = Proof_global.give_me_the_proof pstate in let sigma, env = Pfedit.get_current_context pstate in diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index 7ba7e05019..efd5b5575f 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -40,4 +40,4 @@ val structure_for_compute : (* Show the extraction of the current ongoing proof *) -val show_extraction : pstate:Proof_global.t option -> unit +val show_extraction : pstate:Proof_global.pstate -> unit diff --git a/plugins/extraction/g_extraction.mlg b/plugins/extraction/g_extraction.mlg index db1a389fe7..d43d90af60 100644 --- a/plugins/extraction/g_extraction.mlg +++ b/plugins/extraction/g_extraction.mlg @@ -179,5 +179,11 @@ END VERNAC COMMAND EXTEND ShowExtraction CLASSIFIED AS QUERY | ![ proof ] [ "Show" "Extraction" ] - -> { fun ~pstate -> let () = show_extraction ~pstate in pstate } + -> { fun ~pstate:ontop -> + let pstate = Option.map Proof_global.get_current_pstate ontop in + let pstate = match pstate with + | None -> CErrors.user_err Pp.(str "No ongoing proof") + | Some pstate -> pstate + in + let () = show_extraction ~pstate in ontop } END diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index f2b9ba2ec6..e38ea992ab 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -990,7 +990,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num ] in (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) - let pstate = Lemmas.start_proof ~ontop:None + let pstate = Lemmas.start_proof (*i The next call to mk_equation_id is valid since we are constructing the lemma Ensures by: obvious i*) @@ -1000,8 +1000,9 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num lemma_type in let pstate,_ = Pfedit.by (Proofview.V82.tactic prove_replacement) pstate in - let pstate = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Transparent ~idopt:None in - pstate, evd + let ontop = Proof_global.push ~ontop:None pstate in + ignore(Lemmas.save_proof_proved ?proof:None ~ontop ~opaque:Proof_global.Transparent ~idopt:None); + evd let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = @@ -1015,7 +1016,7 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a Ensures by: obvious i*) let equation_lemma_id = (mk_equation_id f_id) in - evd := snd @@ generate_equation_lemma !evd all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; + evd := generate_equation_lemma !evd all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; let _ = match e with | Option.IsNone -> diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 2c107d39d9..7b26cb0c74 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -309,7 +309,7 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin evd := sigma; let hook = Lemmas.mk_hook (hook new_principle_type) in let pstate = - Lemmas.start_proof ~ontop:None + Lemmas.start_proof new_princ_name (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) !evd @@ -328,8 +328,7 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin let { id; entries; persistence } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pstate in match entries with | [entry] -> - let pstate = discard_current pstate in - (id,(entry,persistence)), hook, pstate + (id,(entry,persistence)), hook | _ -> CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") @@ -381,7 +380,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) register_with_sort InProp; register_with_sort InSet in - let ((id,(entry,g_kind)),hook,pstate) = + let ((id,(entry,g_kind)),hook) = build_functional_principle evd interactive_proof old_princ_type new_sorts funs i proof_tac hook in @@ -520,7 +519,7 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ s::l_schemes -> s,l_schemes | _ -> anomaly (Pp.str "") in - let ((_,(const,_)),_,pstate) = + let ((_,(const,_)),_) = try build_functional_principle evd false first_type @@ -580,7 +579,7 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ (* If we reach this point, the two principle are not mutually recursive We fall back to the previous method *) - let ((_,(const,_)),_,pstate) = + let ((_,(const,_)),_) = build_functional_principle evd false diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index dbfc0fc91d..b8db3dc5ce 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -190,7 +190,9 @@ VERNAC COMMAND EXTEND Function | Vernacextend.VtSideff ids, _ when hard -> Vernacextend.(VtStartProof (GuaranteesOpacity, ids), VtLater) | x -> x } - -> { do_generate_principle false (List.map snd recsl) } + -> { fun ~pstate:ontop -> + let pstate = do_generate_principle false (List.map snd recsl) in + Proof_global.maybe_push ~ontop pstate} END { @@ -228,30 +230,30 @@ VERNAC COMMAND EXTEND NewFunctionalScheme | ![ proof ] ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] => { Vernacextend.(VtSideff(List.map pi1 fas), VtLater) } -> - { fun ~pstate -> + { fun ~pstate:ontop -> begin try - Functional_principles_types.build_scheme fas; pstate + Functional_principles_types.build_scheme fas; ontop with | Functional_principles_types.No_graph_found -> begin match fas with | (_,fun_name,_)::_ -> begin - let pstate = make_graph ~pstate (Smartlocate.global_with_alias fun_name) in - try Functional_principles_types.build_scheme fas; pstate + let ontop = make_graph ~ontop (Smartlocate.global_with_alias fun_name) in + try Functional_principles_types.build_scheme fas; ontop with | Functional_principles_types.No_graph_found -> CErrors.user_err Pp.(str "Cannot generate induction principle(s)") | e when CErrors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in - warning_error names e; pstate + warning_error names e; ontop end | _ -> assert false (* we can only have non empty list *) end | e when CErrors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in - warning_error names e; pstate + warning_error names e; ontop end } END @@ -266,5 +268,5 @@ END (***** debug only ***) VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY | ![ proof ] ["Generate" "graph" "for" reference(c)] -> - { make_graph (Smartlocate.global_with_alias c) } + { fun ~pstate:ontop -> make_graph ~ontop (Smartlocate.global_with_alias c) } END diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index a6b088de0c..d47c12a7cb 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -410,7 +410,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error with e when CErrors.noncritical e -> on_error names e -let register_struct ~pstate is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = +let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = match fixpoint_exprl with | [(({CAst.v=fname},pl),_,bl,ret_type,body),_] when not is_rec -> let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in @@ -432,9 +432,9 @@ let register_struct ~pstate is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * V (Evd.from_env (Global.env ()),[]) fixpoint_exprl in - pstate, evd,List.rev rev_pconstants + None, evd,List.rev rev_pconstants | _ -> - let pstate = ComFixpoint.do_fixpoint ~ontop:pstate Global false fixpoint_exprl in + let pstate = ComFixpoint.do_fixpoint Global false fixpoint_exprl in let evd,rev_pconstants = List.fold_left (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) -> @@ -633,8 +633,8 @@ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacex fixpoint_exprl_with_new_bl -let do_generate_principle ~pstate pconstants on_error register_built interactive_proof - (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) : Proof_global.t option = +let do_generate_principle pconstants on_error register_built interactive_proof + (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) : Proof_global.pstate option = List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl; let pstate, _is_struct = match fixpoint_exprl with @@ -661,7 +661,7 @@ let do_generate_principle ~pstate pconstants on_error register_built interactive in if register_built then register_wf name rec_impls wf_rel wf_x.CAst.v using_lemmas args types body pre_hook, false - else pstate, false + else None, false |[((_,Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)},_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},_),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with @@ -685,7 +685,7 @@ let do_generate_principle ~pstate pconstants on_error register_built interactive in if register_built then register_mes name rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook, true - else pstate, true + else None, true | _ -> List.iter (function ((_na,ord,_args,_body,_type),_not) -> match ord with @@ -704,8 +704,8 @@ let do_generate_principle ~pstate pconstants on_error register_built interactive let is_rec = List.exists (is_rec fix_names) recdefs in let pstate,evd,pconstants = if register_built - then register_struct ~pstate is_rec fixpoint_exprl - else pstate, Evd.from_env (Global.env ()), pconstants + then register_struct is_rec fixpoint_exprl + else None, Evd.from_env (Global.env ()), pconstants in let evd = ref evd in generate_principle @@ -839,9 +839,7 @@ let rec get_args b t : Constrexpr.local_binder_expr list * | _ -> [],b,t -let make_graph ~pstate (f_ref : GlobRef.t) = - let sigma, env = Option.cata Pfedit.get_current_context - (let e = Global.env () in Evd.from_env e, e) pstate in +let make_graph env sigma (f_ref : GlobRef.t) = let c,c_body = match f_ref with | ConstRef c -> @@ -902,11 +900,18 @@ let make_graph ~pstate (f_ref : GlobRef.t) = [((CAst.make id,None),None,nal_tas,t,Some b),[]] in let mp = Constant.modpath c in - let pstate = do_generate_principle ~pstate [c,Univ.Instance.empty] error_error false false expr_list in + let pstate = do_generate_principle [c,Univ.Instance.empty] error_error false false expr_list in (* We register the infos *) List.iter (fun ((({CAst.v=id},_),_,_,_,_),_) -> add_Function false (Constant.make2 mp (Label.of_id id))) expr_list; pstate) +let make_graph ~ontop f_ref = + let pstate = Option.map Proof_global.get_current_pstate ontop in + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in + Option.cata (fun ps -> Some (Proof_global.push ~ontop ps)) ontop + (make_graph env sigma f_ref) + let do_generate_principle = do_generate_principle [] warning_error true diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index acf85f539e..cf4ef23d1a 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -5,10 +5,10 @@ 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 : pstate:Proof_global.t option -> +val do_generate_principle : bool -> (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> - Proof_global.t option + Proof_global.pstate option val functional_induction : bool -> @@ -17,4 +17,4 @@ val functional_induction : Ltac_plugin.Tacexpr.or_and_intro_pattern option -> Goal.goal Evd.sigma -> Goal.goal list Evd.sigma -val make_graph : pstate:Proof_global.t option -> GlobRef.t -> Proof_global.t option +val make_graph : ontop:Proof_global.t option -> GlobRef.t -> Proof_global.t option diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 2a0140f02c..03568fc6c7 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -803,7 +803,7 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list i*) let lem_id = mk_correct_id f_id in let (typ,_) = lemmas_types_infos.(i) in - let pstate = Lemmas.start_proof ~ontop:None + let pstate = Lemmas.start_proof lem_id (Decl_kinds.Global,false,((Decl_kinds.Proof Decl_kinds.Theorem))) !evd @@ -811,7 +811,7 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list let pstate = fst @@ Pfedit.by (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") (proving_tac i))) pstate in - let _ = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Transparent ~idopt:None in + let () = Lemmas.save_pstate_proved ~pstate ~opaque:Proof_global.Transparent ~idopt:None in let finfo = find_Function_infos (fst f_as_constant) in (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) let _,lem_cst_constr = Evd.fresh_global @@ -865,13 +865,13 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list Ensures by: obvious i*) let lem_id = mk_complete_id f_id in - let pstate = Lemmas.start_proof ~ontop:None lem_id + let pstate = Lemmas.start_proof lem_id (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) sigma (fst lemmas_types_infos.(i)) in let pstate = fst (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") (proving_tac i))) pstate) in - let _pstate = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Transparent ~idopt:None in + let () = Lemmas.save_pstate_proved ~pstate ~opaque:Proof_global.Transparent ~idopt:None in let finfo = find_Function_infos (fst f_as_constant) in let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index de1b592337..b4d0f092d8 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -72,7 +72,7 @@ let declare_fun f_id kind ?univs value = let ce = definition_entry ?univs value (*FIXME *) in ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; -let defined pstate = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Transparent ~idopt:None +let defined pstate = Lemmas.save_pstate_proved ~pstate ~opaque:Proof_global.Transparent ~idopt:None let def_of_const t = match (Constr.kind t) with @@ -1367,10 +1367,9 @@ let open_new_goal pstate build_proof sigma using_lemmas ref_ goal_name (gls_type ) g) in - let _pstate = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:opacity ~idopt:None in - () + Lemmas.save_pstate_proved ~pstate ~opaque:opacity ~idopt:None in - let pstate = Lemmas.start_proof ~ontop:(Some pstate) + let pstate = Lemmas.start_proof na (Decl_kinds.Global, false (* FIXME *), Decl_kinds.Proof Decl_kinds.Lemma) sigma gls_type ~hook:(Lemmas.mk_hook hook) in @@ -1399,7 +1398,7 @@ let open_new_goal pstate build_proof sigma using_lemmas ref_ goal_name (gls_type try Some (fst @@ by (Proofview.V82.tactic tclIDTAC) pstate) (* raises UserError _ if the proof is complete *) with UserError _ -> - defined pstate + (defined pstate; None) let com_terminate tcc_lemma_name @@ -1413,7 +1412,7 @@ let com_terminate nb_args ctx hook = let start_proof env ctx (tac_start:tactic) (tac_end:tactic) = - let pstate = Lemmas.start_proof ~ontop:None thm_name + let pstate = Lemmas.start_proof thm_name (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) ~hook in let pstate = fst @@ by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "starting_tac") tac_start)) pstate in @@ -1431,7 +1430,8 @@ let com_terminate with EmptySubgoals -> (* a non recursive function declared with measure ! *) tcc_lemma_ref := Not_needed; - defined pstate + defined pstate; + None let start_equation (f:GlobRef.t) (term_f:GlobRef.t) (cont_tactic:Id.t list -> tactic) g = @@ -1459,7 +1459,7 @@ let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation 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 pstate = Lemmas.start_proof ~ontop:None eq_name (Global, false, Proof Lemma) ~sign evd + let pstate = Lemmas.start_proof eq_name (Global, false, Proof Lemma) ~sign evd (EConstr.of_constr equation_lemma_type) in let pstate = fst @@ by (Proofview.V82.tactic (start_equation f_ref terminate_ref @@ -1489,13 +1489,13 @@ let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation } ) )) pstate in - let _ = Flags.silently (fun () -> Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:opacity ~idopt:None) () in + let _ = Flags.silently (fun () -> Lemmas.save_pstate_proved ~pstate ~opaque:opacity ~idopt:None) () in () (* Pp.msgnl (fun _ _ -> str "eqn finished"); *) let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq - generate_induction_principle using_lemmas : Proof_global.t option = + generate_induction_principle using_lemmas : Proof_global.pstate 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 a006c2c354..84d7a399e1 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -14,6 +14,4 @@ bool -> int -> Constrexpr.constr_expr -> (pconstant -> Indfun_common.tcc_lemma_value ref -> pconstant -> - pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> Constrexpr.constr_expr list -> Proof_global.t option - - + pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> Constrexpr.constr_expr list -> Proof_global.pstate option diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 4c186dce09..5e4969567d 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -1118,7 +1118,7 @@ END VERNAC COMMAND EXTEND OptimizeProof | ![ proof ] [ "Optimize" "Proof" ] => { classify_as_proofstep } -> - { fun ~pstate -> Option.map Proof_global.compact_the_proof pstate } + { fun ~pstate -> Option.map Proof_global.(modify_current_pstate compact_the_proof) pstate } | [ "Optimize" "Heap" ] => { classify_as_proofstep } -> { Gc.compact () } END diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index de3a9c9fa9..d7918a58ac 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -80,8 +80,8 @@ GRAMMAR EXTEND Gram open Obligations -let obligation ~pstate obl tac = Some (with_tac (fun t -> Obligations.obligation ~ontop:pstate obl t) tac) -let next_obligation ~pstate obl tac = Some (with_tac (fun t -> Obligations.next_obligation ~ontop:pstate obl t) tac) +let obligation ~pstate obl tac = Some (Proof_global.push ~ontop:pstate (with_tac (fun t -> Obligations.obligation obl t) tac)) +let next_obligation ~pstate obl tac = Some (Proof_global.push ~ontop:pstate (with_tac (fun t -> Obligations.next_obligation obl t) tac)) let classify_obbl _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[]), VtLater) diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index 2fad1f6b6a..e3f4b8ef59 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -280,7 +280,8 @@ VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF (* This command may or may not open a goal *) => { (if Lib.is_modtype() then VtSideff([n]) else VtStartProof(GuaranteesOpacity, [n])), VtLater } -> { - add_morphism_infer atts m n + fun ~pstate:ontop -> + Option.cata (fun ps -> Some (Proof_global.push ~ontop ps)) ontop (add_morphism_infer atts m n) } | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] => { VtStartProof(GuaranteesOpacity,[n]), VtLater } diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 6f84e6c18d..efca411754 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1974,7 +1974,7 @@ let warn_add_morphism_deprecated = CWarnings.create ~name:"add-morphism" ~category:"deprecated" (fun () -> Pp.(str "Add Morphism f : id is deprecated, please use Add Morphism f with signature (...) as id")) -let add_morphism_infer ~pstate atts m n : Proof_global.t option = +let add_morphism_infer atts m n : Proof_global.pstate option = warn_add_morphism_deprecated ?loc:m.CAst.loc (); init_setoid (); let instance_id = add_suffix n "_Proper" in @@ -1991,7 +1991,7 @@ let add_morphism_infer ~pstate atts m n : Proof_global.t option = add_instance (Classes.mk_instance (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (ConstRef cst)); declare_projection n instance_id (ConstRef cst); - pstate + None else let kind = Decl_kinds.Global, atts.polymorphic, Decl_kinds.DefinitionBody Decl_kinds.Instance @@ -2008,7 +2008,7 @@ let add_morphism_infer ~pstate atts m n : Proof_global.t option = let hook = Lemmas.mk_hook hook in Flags.silently (fun () -> - let pstate = Lemmas.start_proof ~ontop:pstate ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) in + let pstate = Lemmas.start_proof ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) in Some (fst Pfedit.(by (Tacinterp.interp tac) pstate))) () let add_morphism ~pstate atts binders m s n = diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index a200cb5ced..cab7d0065e 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -89,7 +89,7 @@ val add_setoid : pstate:Proof_global.t option -> rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> constr_expr -> Id.t -> Proof_global.t option -val add_morphism_infer : pstate:Proof_global.t option -> rewrite_attributes -> constr_expr -> Id.t -> Proof_global.t option +val add_morphism_infer : rewrite_attributes -> constr_expr -> Id.t -> Proof_global.pstate option val add_morphism : pstate:Proof_global.t option -> rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> Proof_global.t option diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 7333114eae..66b47a64a7 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -108,7 +108,7 @@ let solve ?with_end_tac gi info_lvl tac pr = in (p,status) -let by tac = Proof_global.with_current_proof (fun _ -> solve (Goal_select.SelectNth 1) None tac) +let by tac = Proof_global.with_proof (fun _ -> solve (Goal_select.SelectNth 1) None tac) (**********************************************************************) (* Shortcut to build a term using tactics *) @@ -121,7 +121,7 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo let evd = Evd.from_ctx ctx in let terminator = Proof_global.make_terminator (fun _ -> ()) in let goals = [ (Global.env_of_context sign , typ) ] in - let pf = Proof_global.start_proof ~ontop:None evd id goal_kind goals terminator in + let pf = Proof_global.start_proof evd id goal_kind goals terminator in try let pf, status = by tac pf in let open Proof_global in diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 77d701b41f..ec52d2d5cf 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -23,17 +23,17 @@ exception NoSuchGoal the current focused proof or raises a [UserError] if there is no focused proof or if there is no more subgoals *) -val get_goal_context : Proof_global.t -> int -> Evd.evar_map * env +val get_goal_context : Proof_global.pstate -> int -> Evd.evar_map * env (** [get_current_goal_context ()] works as [get_goal_context 1] *) -val get_current_goal_context : Proof_global.t -> Evd.evar_map * env +val get_current_goal_context : Proof_global.pstate -> Evd.evar_map * env (** [get_current_context ()] returns the context of the current focused goal. If there is no focused goal but there is a proof in progress, it returns the corresponding evar_map. If there is no pending proof then it returns the current global environment and empty evar_map. *) -val get_current_context : Proof_global.t -> Evd.evar_map * env +val get_current_context : Proof_global.pstate -> Evd.evar_map * env (** {6 ... } *) @@ -49,7 +49,7 @@ val solve : ?with_end_tac:unit Proofview.tactic -> focused proof. Returns [false] if an unsafe tactic has been used. *) -val by : unit Proofview.tactic -> Proof_global.t -> Proof_global.t * bool +val by : unit Proofview.tactic -> Proof_global.pstate -> Proof_global.pstate * bool (** Option telling if unification heuristics should be used. *) val use_unification_heuristics : unit -> bool diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 40ae4acc88..8d7960829b 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -63,23 +63,40 @@ let pstate_map f (pf, pfl) = (f pf, List.map f pfl) let make_terminator f = f let apply_terminator f = f +let get_current_pstate (ps,_) = ps + (* combinators for the current_proof lists *) let push ~ontop a = match ontop with | None -> a , [] | Some (l,ls) -> a, (l :: ls) +let maybe_push ~ontop = function + | Some pstate -> Some (push ~ontop pstate) + | None -> ontop + (*** Proof Global manipulation ***) let get_all_proof_names (pf : t) = let (pn, pns) = pstate_map Proof.(function pf -> (data pf.proof).name) pf in pn :: pns -let give_me_the_proof (ps,_) = ps.proof -let get_current_proof_name (ps,_) = (Proof.data ps.proof).Proof.name -let get_current_persistence (ps,_) = ps.strength +let give_me_the_proof ps = ps.proof +let get_current_proof_name ps = (Proof.data ps.proof).Proof.name +let get_current_persistence ps = ps.strength + +let with_current_pstate f (ps,psl) = + let ps, ret = f ps in + (ps, psl), ret + +let modify_current_pstate f (ps,psl) = + f ps, psl + +let modify_proof f ps = + let proof = f ps.proof in + {ps with proof} -let with_current_proof f (ps, psl) = +let with_proof f ps = let et = match ps.endline_tactic with | None -> Proofview.tclUNIT () @@ -92,16 +109,23 @@ let with_current_proof f (ps, psl) = in let (newpr,ret) = f et ps.proof in let ps = { ps with proof = newpr } in - (ps, psl), ret + ps, ret + +let with_current_proof f (ps,rest) = + let ps, ret = with_proof f ps in + (ps, rest), ret let simple_with_current_proof f pf = let p, () = with_current_proof (fun t p -> f t p , ()) pf in p -let compact_the_proof pf = simple_with_current_proof (fun _ -> Proof.compact) pf +let simple_with_proof f ps = + let ps, () = with_proof (fun t ps -> f t ps, ()) ps in ps + +let compact_the_proof pf = simple_with_proof (fun _ -> Proof.compact) pf (* Sets the tactic to be used when a tactic line is closed with [...] *) -let set_endline_tactic tac (ps, psl) = - { ps with endline_tactic = Some tac }, psl +let set_endline_tactic tac ps = + { ps with endline_tactic = Some tac } let pf_name_eq id ps = let Proof.{ name } = Proof.data ps.proof in @@ -112,8 +136,10 @@ let discard {CAst.loc;v=id} (ps, psl) = | [] -> None | ps :: psl -> Some (ps, psl) -let discard_current (ps, psl) = - if List.is_empty psl then None else Some List.(hd psl, tl psl) +let discard_current (_, psl) = + match psl with + | [] -> None + | ps :: psl -> Some (ps, psl) (** [start_proof sigma id pl str goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and @@ -123,30 +149,26 @@ let discard_current (ps, psl) = end of the proof to close the proof. The proof is started in the evar map [sigma] (which can typically contain universe constraints), and with universe bindings pl. *) -let start_proof ~ontop sigma name ?(pl=UState.default_univ_decl) kind goals terminator = - let initial_state = { - terminator = CEphemeron.create terminator; +let start_proof sigma name ?(pl=UState.default_univ_decl) kind goals terminator = + { terminator = CEphemeron.create terminator; proof = Proof.start ~name ~poly:(pi2 kind) sigma goals; endline_tactic = None; section_vars = None; universe_decl = pl; - strength = kind } in - push ~ontop initial_state + strength = kind } -let start_dependent_proof ~ontop name ?(pl=UState.default_univ_decl) kind goals terminator = - let initial_state = { - terminator = CEphemeron.create terminator; +let start_dependent_proof name ?(pl=UState.default_univ_decl) kind goals terminator = + { terminator = CEphemeron.create terminator; proof = Proof.dependent_start ~name ~poly:(pi2 kind) goals; endline_tactic = None; section_vars = None; universe_decl = pl; - strength = kind } in - push ~ontop initial_state + strength = kind } -let get_used_variables (pf,_) = pf.section_vars -let get_universe_decl (pf,_) = pf.universe_decl +let get_used_variables pf = pf.section_vars +let get_universe_decl pf = pf.universe_decl -let set_used_variables (ps,psl) l = +let set_used_variables ps l = let open Context.Named.Declaration in let env = Global.env () in let ids = List.fold_right Id.Set.add l Id.Set.empty in @@ -170,9 +192,9 @@ let set_used_variables (ps,psl) l = if not (Option.is_empty ps.section_vars) then CErrors.user_err Pp.(str "Used section variables can be declared only once"); (* EJGA: This is always empty thus we should modify the type *) - (ctx, []), ({ ps with section_vars = Some ctx}, psl) + (ctx, []), { ps with section_vars = Some ctx} -let get_open_goals (ps, _) = +let get_open_goals ps = let Proof.{ goals; stack; shelf } = Proof.data ps.proof in List.length goals + List.fold_left (+) 0 @@ -293,7 +315,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now universes }, fun pr_ending -> CEphemeron.get terminator pr_ending -let return_proof ?(allow_partial=false) (ps,_) = +let return_proof ?(allow_partial=false) ps = let { proof } = ps in if allow_partial then begin let proofs = Proof.partial_proof proof in @@ -322,27 +344,27 @@ let return_proof ?(allow_partial=false) (ps,_) = List.map (fun (c, _) -> (proof_opt c, eff)) initial_goals in proofs, Evd.evar_universe_context evd -let close_future_proof ~opaque ~feedback_id (ps, psl) proof = +let close_future_proof ~opaque ~feedback_id ps proof = close_proof ~opaque ~keep_body_ucst_separate:true ~feedback_id ~now:false proof ps -let close_proof ~opaque ~keep_body_ucst_separate fix_exn (ps, psl) = +let close_proof ~opaque ~keep_body_ucst_separate fix_exn ps = close_proof ~opaque ~keep_body_ucst_separate ~now:true - (Future.from_val ~fix_exn (return_proof (ps,psl))) ps + (Future.from_val ~fix_exn (return_proof ps)) ps (** Gets the current terminator without checking that the proof has been completed. Useful for the likes of [Admitted]. *) -let get_terminator (ps, _) = CEphemeron.get ps.terminator -let set_terminator hook (ps, psl) = - { ps with terminator = CEphemeron.create hook }, psl +let get_terminator ps = CEphemeron.get ps.terminator +let set_terminator hook ps = + { ps with terminator = CEphemeron.create hook } let copy_terminators ~src ~tgt = let (ps, psl), (ts,tsl) = src, tgt in assert(List.length psl = List.length tsl); {ts with terminator = ps.terminator}, List.map2 (fun op p -> { p with terminator = op.terminator }) psl tsl -let update_global_env (pf : t) = +let update_global_env pf = let res, () = - with_current_proof (fun _ p -> + with_proof (fun _ p -> Proof.in_proof p (fun sigma -> let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in let (p,(status,info),()) = Proof.run_tactic (Global.env ()) tac p in diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index e2e457483b..6984fff63a 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -12,16 +12,20 @@ toplevel. In particular it defines the global proof environment. *) +type pstate type t -val get_current_proof_name : t -> Names.Id.t -val get_current_persistence : t -> Decl_kinds.goal_kind + +val get_current_pstate : t -> pstate + +val get_current_proof_name : pstate -> Names.Id.t +val get_current_persistence : pstate -> Decl_kinds.goal_kind val get_all_proof_names : t -> Names.Id.t list val discard : Names.lident -> t -> t option val discard_current : t -> t option -val give_me_the_proof : t -> Proof.t -val compact_the_proof : t -> t +val give_me_the_proof : pstate -> Proof.t +val compact_the_proof : pstate -> pstate (** When a proof is closed, it is reified into a [proof_object], where [id] is the name of the proof, [entries] the list of the proof terms @@ -52,6 +56,10 @@ type closed_proof = proof_object * proof_terminator val make_terminator : (proof_ending -> unit) -> proof_terminator val apply_terminator : proof_terminator -> proof_ending -> unit +val push : ontop:t option -> pstate -> t + +val maybe_push : ontop:t option -> pstate option -> t option + (** [start_proof ~ontop id str pl goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and conclusion); [str] describes what kind of theorem/definition this @@ -60,25 +68,26 @@ val apply_terminator : proof_terminator -> proof_ending -> unit morphism). The proof is started in the evar map [sigma] (which can typically contain universe constraints), and with universe bindings pl. *) -val start_proof : ontop:t option -> +val start_proof : Evd.evar_map -> Names.Id.t -> ?pl:UState.universe_decl -> Decl_kinds.goal_kind -> (Environ.env * EConstr.types) list -> - proof_terminator -> t + proof_terminator -> pstate (** Like [start_proof] except that there may be dependencies between initial goals. *) -val start_dependent_proof : ontop:t option -> +val start_dependent_proof : Names.Id.t -> ?pl:UState.universe_decl -> Decl_kinds.goal_kind -> - Proofview.telescope -> proof_terminator -> t + Proofview.telescope -> proof_terminator -> pstate (** Update the proofs global environment after a side-effecting command (e.g. a sublemma definition) has been run inside it. Assumes there_are_pending_proofs. *) -val update_global_env : t -> t +val update_global_env : pstate -> pstate (* Takes a function to add to the exceptions data relative to the state in which the proof was built *) -val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> t -> closed_proof +val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> + pstate -> closed_proof (* Intermediate step necessary to delegate the future. * Both access the current proof state. The former is supposed to be @@ -88,15 +97,15 @@ type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * USt (* If allow_partial is set (default no) then an incomplete proof * is allowed (no error), and a warn is given if the proof is complete. *) -val return_proof : ?allow_partial:bool -> t -> closed_proof_output -val close_future_proof : opaque:opacity_flag -> feedback_id:Stateid.t -> t -> +val return_proof : ?allow_partial:bool -> pstate -> closed_proof_output +val close_future_proof : opaque:opacity_flag -> feedback_id:Stateid.t -> pstate -> closed_proof_output Future.computation -> closed_proof (** Gets the current terminator without checking that the proof has been completed. Useful for the likes of [Admitted]. *) -val get_terminator : t -> proof_terminator -val set_terminator : proof_terminator -> t -> t -val get_open_goals : t -> int +val get_terminator : pstate -> proof_terminator +val set_terminator : proof_terminator -> pstate -> pstate +val get_open_goals : pstate -> int (** Runs a tactic on the current proof. Raises [NoCurrentProof] is there is no current proof. @@ -106,18 +115,24 @@ val with_current_proof : val simple_with_current_proof : (unit Proofview.tactic -> Proof.t -> Proof.t) -> t -> t +val with_proof : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> pstate -> pstate * 'a +val modify_proof : (Proof.t -> Proof.t) -> pstate -> pstate + +val with_current_pstate : (pstate -> pstate * 'a) -> t -> t * 'a +val modify_current_pstate : (pstate -> pstate) -> t -> t + (** Sets the tactic to be used when a tactic line is closed with [...] *) -val set_endline_tactic : Genarg.glob_generic_argument -> t -> t +val set_endline_tactic : Genarg.glob_generic_argument -> pstate -> pstate (** Sets the section variables assumed by the proof, returns its closure * (w.r.t. type dependencies and let-ins covered by it) + a list of * ids to be cleared *) -val set_used_variables : t -> - Names.Id.t list -> (Constr.named_context * Names.lident list) * t +val set_used_variables : pstate -> + Names.Id.t list -> (Constr.named_context * Names.lident list) * pstate -val get_used_variables : t -> Constr.named_context option +val get_used_variables : pstate -> Constr.named_context option (** Get the universe declaration associated to the current proof. *) -val get_universe_decl : t -> UState.universe_decl +val get_universe_decl : pstate -> UState.universe_decl val copy_terminators : src:t -> tgt:t -> t diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 04f10e7399..dfa681395a 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -50,6 +50,7 @@ let is_focused_goal_simple ~doc id = | `Expired | `Error _ | `Valid None -> `Not | `Valid (Some { Vernacstate.proof }) -> Option.cata (fun proof -> + let proof = Proof_global.get_current_pstate proof in let proof = Proof_global.give_me_the_proof proof in let Proof.{ goals=focused; stack=r1; shelf=r2; given_up=r3; sigma } = Proof.data proof in let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in diff --git a/stm/stm.ml b/stm/stm.ml index b2bfa552b4..64f9e4aacf 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1168,7 +1168,9 @@ end = struct (* {{{ *) let get_proof ~doc id = match state_of_id ~doc id with - | `Valid (Some vstate) -> Option.map Proof_global.give_me_the_proof vstate.Vernacstate.proof + | `Valid (Some vstate) -> + Option.map (fun p -> Proof_global.(give_me_the_proof (get_current_pstate p))) + vstate.Vernacstate.proof | _ -> None let undo_vernac_classifier v ~doc = diff --git a/tactics/hints.mli b/tactics/hints.mli index 7b8f96cdd8..396c3e2fed 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -292,7 +292,7 @@ val wrap_hint_warning_fun : env -> evar_map -> (** Printing hints *) val pr_searchtable : env -> evar_map -> Pp.t -val pr_applicable_hint : Proof_global.t -> Pp.t +val pr_applicable_hint : Proof_global.pstate -> Pp.t val pr_hint_ref : env -> evar_map -> GlobRef.t -> Pp.t val pr_hint_db_by_name : env -> evar_map -> hint_db_name -> Pp.t val pr_hint_db_env : env -> evar_map -> Hint_db.t -> Pp.t diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 890ed76d52..49c547a979 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -891,7 +891,7 @@ let classify_ltac2 = function VERNAC COMMAND EXTEND VernacDeclareTactic2Definition | #[ local = locality ] ![proof] [ "Ltac2" ltac2_entry(e) ] => { classify_ltac2 e } -> { - fun ~pstate -> Tac2entries.register_struct ?local ~pstate e; pstate + fun ~pstate -> Tac2entries.register_struct ?local ~pstate:(Option.map Proof_global.get_current_pstate pstate) e; pstate } END diff --git a/user-contrib/Ltac2/tac2entries.mli b/user-contrib/Ltac2/tac2entries.mli index d493192bb3..e02c126e71 100644 --- a/user-contrib/Ltac2/tac2entries.mli +++ b/user-contrib/Ltac2/tac2entries.mli @@ -23,7 +23,7 @@ val register_primitive : ?local:bool -> val register_struct : ?local:bool - -> pstate:Proof_global.t option + -> pstate:Proof_global.pstate option -> strexpr -> unit diff --git a/vernac/classes.ml b/vernac/classes.ml index ea66234993..c783531f91 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -309,7 +309,7 @@ let id_of_class cl = mip.(0).Declarations.mind_typename | _ -> assert false -let instance_hook k info global imps ?hook cst = +let instance_hook info global imps ?hook cst = Impargs.maybe_declare_manual_implicits false cst imps; let info = intern_info info in let env = Global.env () in @@ -317,7 +317,7 @@ let instance_hook k info global imps ?hook cst = declare_instance env sigma (Some info) (not global) cst; (match hook with Some h -> h cst | None -> ()) -let declare_instance_constant k info global imps ?hook id decl poly sigma term termtype = +let declare_instance_constant info global imps ?hook id decl poly sigma term termtype = (* XXX: Duplication of the declare_constant path *) let kind = IsDefinition Instance in let sigma = @@ -331,7 +331,7 @@ let declare_instance_constant k info global imps ?hook id decl poly sigma term t let kn = Declare.declare_constant id cdecl in Declare.definition_message id; Declare.declare_univ_binders (ConstRef kn) (Evd.universe_binders sigma); - instance_hook k info global imps ?hook (ConstRef kn) + instance_hook info global imps ?hook (ConstRef kn) let do_declare_instance env sigma ~global ~poly k u ctx ctx' pri decl imps subst id = let subst = List.fold_left2 @@ -344,66 +344,65 @@ let do_declare_instance env sigma ~global ~poly k u ctx ctx' pri decl imps subst let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id (ParameterEntry entry, Decl_kinds.IsAssumption Decl_kinds.Logical) in Declare.declare_univ_binders (ConstRef cst) (Evd.universe_binders sigma); - instance_hook k pri global imps (ConstRef cst) + instance_hook pri global imps (ConstRef cst) -let declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl ids term termtype = +let declare_instance_program env sigma ~global ~poly id pri imps decl term termtype = + let hook _ _ vis gr = + let cst = match gr with ConstRef kn -> kn | _ -> assert false in + Impargs.declare_manual_implicits false gr imps; + let pri = intern_info pri in + let env = Global.env () in + let sigma = Evd.from_env env in + declare_instance env sigma (Some pri) (not global) (ConstRef cst) + in + let obls, constr, typ = + match term with + | Some t -> + let termtype = EConstr.of_constr termtype in + let obls, _, constr, typ = + Obligations.eterm_obligations env id sigma 0 t termtype + in obls, Some constr, typ + | None -> [||], None, termtype + in + let hook = Lemmas.mk_hook hook in + let ctx = Evd.evar_universe_context sigma in + ignore(Obligations.add_definition id ?term:constr + ~univdecl:decl typ ctx ~kind:(Global,poly,Instance) ~hook obls) + + +let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps decl ids term termtype = + (* spiwack: it is hard to reorder the actions to do + the pretyping after the proof has opened. As a + consequence, we use the low-level primitives to code + the refinement manually.*) + let gls = List.rev (Evd.future_goals sigma) in + let sigma = Evd.reset_future_goals sigma in let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in - if program_mode then - let hook _ _ vis gr = - let cst = match gr with ConstRef kn -> kn | _ -> assert false in - Impargs.declare_manual_implicits false gr imps; - let pri = intern_info pri in - let env = Global.env () in - let sigma = Evd.from_env env in - declare_instance env sigma (Some pri) (not global) (ConstRef cst) - in - let obls, constr, typ = - match term with - | Some t -> - let termtype = EConstr.of_constr termtype in - let obls, _, constr, typ = - Obligations.eterm_obligations env id sigma 0 t termtype - in obls, Some constr, typ - | None -> [||], None, termtype - in - let hook = Lemmas.mk_hook hook in - let ctx = Evd.evar_universe_context sigma in - let _progress = Obligations.add_definition id ?term:constr - ~univdecl:decl typ ctx ~kind:(Global,poly,Instance) ~hook obls in + let pstate = Lemmas.start_proof id ~pl:decl kind sigma (EConstr.of_constr termtype) + ~hook:(Lemmas.mk_hook + (fun _ _ _ -> instance_hook pri global imps ?hook)) in + (* spiwack: I don't know what to do with the status here. *) + let pstate = + if not (Option.is_empty term) then + let init_refine = + Tacticals.New.tclTHENLIST [ + Refine.refine ~typecheck:false (fun sigma -> (sigma, Option.get term)); + Proofview.Unsafe.tclNEWGOALS (CList.map Proofview.with_empty_state gls); + Tactics.New.reduce_after_refine; + ] + in + let pstate, _ = Pfedit.by init_refine pstate in + pstate + else + let pstate, _ = Pfedit.by (Tactics.auto_intros_tac ids) pstate in + pstate + in + match tac with + | Some tac -> + let pstate, _ = Pfedit.by tac pstate in + pstate + | None -> pstate - else - Some Flags.(silently (fun () -> - (* spiwack: it is hard to reorder the actions to do - the pretyping after the proof has opened. As a - consequence, we use the low-level primitives to code - the refinement manually.*) - let gls = List.rev (Evd.future_goals sigma) in - let sigma = Evd.reset_future_goals sigma in - let pstate = Lemmas.start_proof ~ontop:pstate id ~pl:decl kind sigma (EConstr.of_constr termtype) - ~hook:(Lemmas.mk_hook - (fun _ _ _ -> instance_hook k pri global imps ?hook)) in - (* spiwack: I don't know what to do with the status here. *) - let pstate = - if not (Option.is_empty term) then - let init_refine = - Tacticals.New.tclTHENLIST [ - Refine.refine ~typecheck:false (fun sigma -> (sigma, Option.get term)); - Proofview.Unsafe.tclNEWGOALS (CList.map Proofview.with_empty_state gls); - Tactics.New.reduce_after_refine; - ] - in - let pstate, _ = Pfedit.by init_refine pstate in - pstate - else - let pstate, _ = Pfedit.by (Tactics.auto_intros_tac ids) pstate in - pstate - in - match tac with - | Some tac -> - let pstate, _ = Pfedit.by tac pstate in - pstate - | None -> - pstate) ()) let do_instance ~pstate env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = let props = @@ -487,10 +486,18 @@ let do_instance ~pstate env env' sigma ?hook ~tac ~global ~poly ~program_mode ct let pstate = if not (Evd.has_undefined sigma) && not (Option.is_empty props) then let term = to_constr sigma (Option.get term) in - (declare_instance_constant k pri global imps ?hook id decl poly sigma term termtype; - None) - else if program_mode || Option.is_empty props then - declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl (List.map RelDecl.get_name ctx) term termtype + (declare_instance_constant pri global imps ?hook id decl poly sigma term termtype; + pstate) + else if program_mode then + (declare_instance_program env sigma ~global ~poly id pri imps decl term termtype ; pstate) + else if Option.is_empty props then + let pstate' = + Flags.silently (fun () -> + declare_instance_open sigma ?hook ~tac ~global ~poly + id pri imps decl (List.map RelDecl.get_name ctx) term termtype) + () + in + Some (Proof_global.push ~ontop:pstate pstate') else CErrors.user_err Pp.(str "Unsolved obligations remaining.") in id, pstate diff --git a/vernac/classes.mli b/vernac/classes.mli index 8d5f3e3a06..f80dbb9897 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -31,20 +31,6 @@ val declare_instance : ?warn:bool -> env -> Evd.evar_map -> val existing_instance : bool -> qualid -> Hints.hint_info_expr option -> unit (** globality, reference, optional priority and pattern information *) -val declare_instance_constant : - typeclass -> - Hints.hint_info_expr (** priority *) -> - bool (** globality *) -> - Impargs.manual_explicitation list (** implicits *) -> - ?hook:(GlobRef.t -> unit) -> - Id.t (** name *) -> - UState.universe_decl -> - bool (** polymorphic *) -> - Evd.evar_map (** Universes *) -> - Constr.t (** body *) -> - Constr.types (** type *) -> - unit - val new_instance : pstate:Proof_global.t option -> ?global:bool (** Not global by default. *) diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index a428c42e49..006ac314a5 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -255,7 +255,7 @@ let interp_fixpoint ~cofix l ntns = let uctx,fix = ground_fixpoint env evd fix in (fix,pl,uctx,info) -let declare_fixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = +let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = let pstate = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) @@ -267,7 +267,7 @@ let declare_fixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx fixdefs) in let evd = Evd.from_ctx ctx in Some - (Lemmas.start_proof_with_initialization ~ontop (local,poly,DefinitionBody Fixpoint) + (Lemmas.start_proof_with_initialization (local,poly,DefinitionBody Fixpoint) evd pl (Some(false,indexes,init_tac)) thms None) else begin (* We shortcut the proof process *) @@ -294,7 +294,7 @@ let declare_fixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; pstate -let declare_cofixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = +let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = let pstate = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) @@ -305,7 +305,7 @@ let declare_cofixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,c Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in let evd = Evd.from_ctx ctx in - Some (Lemmas.start_proof_with_initialization ~ontop (Global,poly, DefinitionBody CoFixpoint) + Some (Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) evd pl (Some(true,[],init_tac)) thms None) else begin (* We shortcut the proof process *) @@ -366,18 +366,18 @@ let check_safe () = let flags = Environ.typing_flags (Global.env ()) in flags.check_universes && flags.check_guarded -let do_fixpoint ~ontop local poly l = +let do_fixpoint local poly l = let fixl, ntns = extract_fixpoint_components ~structonly:true l in let (_, _, _, info as fix) = interp_fixpoint ~cofix:false fixl ntns in let possible_indexes = List.map compute_possible_guardness_evidences info in - let pstate = declare_fixpoint ~ontop local poly fix possible_indexes ntns in + let pstate = declare_fixpoint local poly fix possible_indexes ntns in if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else (); pstate -let do_cofixpoint ~ontop local poly l = +let do_cofixpoint local poly l = let fixl,ntns = extract_cofixpoint_components l in let cofix = interp_fixpoint ~cofix:true fixl ntns in - let pstate = declare_cofixpoint ~ontop local poly cofix ntns in + let pstate = declare_cofixpoint local poly cofix ntns in if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else (); pstate diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index 5937842f17..d36593332e 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -19,14 +19,12 @@ open Vernacexpr (** Entry points for the vernacular commands Fixpoint and CoFixpoint *) val do_fixpoint : - ontop:Proof_global.t option -> (* When [false], assume guarded. *) - locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> Proof_global.t option + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> Proof_global.pstate option val do_cofixpoint : - ontop:Proof_global.t option -> (* When [false], assume guarded. *) - locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> Proof_global.t option + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> Proof_global.pstate option (************************************************************************) (** Internal API *) @@ -83,20 +81,18 @@ val interp_fixpoint : (** [Not used so far] *) val declare_fixpoint : - ontop:Proof_global.t option -> locality -> polymorphic -> recursive_preentry * UState.universe_decl * UState.t * (Constr.rel_context * Impargs.manual_implicits * int option) list -> Proof_global.lemma_possible_guards -> decl_notation list -> - Proof_global.t option + Proof_global.pstate option val declare_cofixpoint : - ontop:Proof_global.t option -> locality -> polymorphic -> recursive_preentry * UState.universe_decl * UState.t * (Constr.rel_context * Impargs.manual_implicits * int option) list -> decl_notation list -> - Proof_global.t option + Proof_global.pstate option (** Very private function, do not use *) val compute_possible_guardness_evidences : diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 740b9031cc..d0ec575eb3 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -329,7 +329,7 @@ let initialize_named_context_for_proof () = let d = if variable_opacity id then NamedDecl.drop_body d else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val -let start_proof ~ontop id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?hook c = +let start_proof id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?hook c = let terminator = match terminator with | None -> standard_proof_terminator ?hook compute_guard | Some terminator -> terminator ?hook compute_guard @@ -340,7 +340,7 @@ let start_proof ~ontop id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ? | None -> initialize_named_context_for_proof () in let goals = [ Global.env_of_context sign , c ] in - Proof_global.start_proof ~ontop sigma id ?pl kind goals terminator + Proof_global.start_proof sigma id ?pl kind goals terminator let rec_tac_initializer finite guard thms snl = if finite then @@ -356,7 +356,7 @@ let rec_tac_initializer finite guard thms snl = | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false -let start_proof_with_initialization ~ontop ?hook kind sigma decl recguard thms snl = +let start_proof_with_initialization ?hook kind sigma decl recguard thms snl = let intro_tac (_, (_, (ids, _))) = Tactics.auto_intros_tac ids in let init_tac,guard = match recguard with | Some (finite,guard,init_tac) -> @@ -388,14 +388,14 @@ let start_proof_with_initialization ~ontop ?hook kind sigma decl recguard thms s List.iter (fun (strength,ref,imps) -> maybe_declare_manual_implicits false ref imps; call_hook ?hook ctx [] strength ref) thms_data in - let pstate = start_proof ~ontop id ~pl:decl kind sigma t ~hook ~compute_guard:guard in - let pstate = Proof_global.simple_with_current_proof (fun _ p -> + let pstate = start_proof id ~pl:decl kind sigma t ~hook ~compute_guard:guard in + let pstate = Proof_global.modify_proof (fun p -> match init_tac with | None -> p | Some tac -> pi1 @@ Proof.run_tactic Global.(env ()) tac p) pstate in pstate -let start_proof_com ~program_mode ~ontop ?inference_hook ?hook kind thms = +let start_proof_com ~program_mode ?inference_hook ?hook kind thms = let env0 = Global.env () in let decl = fst (List.hd thms) in let evd, decl = Constrexpr_ops.interp_univ_decl_opt env0 (snd decl) in @@ -427,7 +427,7 @@ let start_proof_com ~program_mode ~ontop ?inference_hook ?hook kind thms = else (* We fix the variables to ensure they won't be lowered to Set *) Evd.fix_undefined_variables evd in - start_proof_with_initialization ~ontop ?hook kind evd decl recguard thms snl + start_proof_with_initialization ?hook kind evd decl recguard thms snl (* Saving a proof *) @@ -487,20 +487,26 @@ let save_proof_admitted ?proof ~pstate = in Proof_global.apply_terminator (Proof_global.get_terminator pstate) pe -let save_proof_proved ?proof ?pstate ~opaque ~idopt = +let save_pstate_proved ~pstate ~opaque ~idopt = + let obj, terminator = Proof_global.close_proof ~opaque + ~keep_body_ucst_separate:false (fun x -> x) pstate + in + Proof_global.(apply_terminator terminator (Proved (opaque, idopt, obj))) + +let save_proof_proved ?proof ?ontop ~opaque ~idopt = (* Invariant (uh) *) - if Option.is_empty pstate && Option.is_empty proof then + if Option.is_empty ontop && Option.is_empty proof then user_err (str "No focused proof (No proof-editing in progress)."); let (proof_obj,terminator) = match proof with | None -> (* XXX: The close_proof and proof state API should be refactored so it is possible to insert proofs properly into the state *) - let pstate = Option.get pstate in + let pstate = Proof_global.get_current_pstate @@ Option.get ontop in Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) pstate | Some proof -> proof in (* if the proof is given explicitly, nothing has to be deleted *) - let pstate = if Option.is_empty proof then Proof_global.discard_current Option.(get pstate) else pstate in + let ontop = if Option.is_empty proof then Proof_global.discard_current Option.(get ontop) else ontop in Proof_global.(apply_terminator terminator (Proved (opaque,idopt,proof_obj))); - pstate + ontop diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 1f70cfa1ad..ad6eb024aa 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -37,26 +37,25 @@ val call_hook -> ?fix_exn:Future.fix_exn -> hook_type -val start_proof : ontop:Proof_global.t option -> Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> +val start_proof : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> ?terminator:(?hook:declaration_hook -> Proof_global.lemma_possible_guards -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> ?compute_guard:Proof_global.lemma_possible_guards -> - ?hook:declaration_hook -> EConstr.types -> Proof_global.t + ?hook:declaration_hook -> EConstr.types -> Proof_global.pstate val start_proof_com : program_mode:bool - -> ontop:Proof_global.t option -> ?inference_hook:Pretyping.inference_hook -> ?hook:declaration_hook -> goal_kind -> Vernacexpr.proof_expr list - -> Proof_global.t + -> Proof_global.pstate -val start_proof_with_initialization : ontop:Proof_global.t option -> +val start_proof_with_initialization : ?hook:declaration_hook -> goal_kind -> Evd.evar_map -> UState.universe_decl -> (bool * Proof_global.lemma_possible_guards * unit Proofview.tactic list option) option -> (Id.t (* name of thm *) * (EConstr.types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list - -> int list option -> Proof_global.t + -> int list option -> Proof_global.pstate val standard_proof_terminator : ?hook:declaration_hook -> Proof_global.lemma_possible_guards -> @@ -73,12 +72,18 @@ val initialize_named_context_for_proof : unit -> Environ.named_context_val val save_proof_admitted : ?proof:Proof_global.closed_proof - -> pstate:Proof_global.t + -> pstate:Proof_global.pstate -> unit val save_proof_proved : ?proof:Proof_global.closed_proof - -> ?pstate:Proof_global.t + -> ?ontop:Proof_global.t -> opaque:Proof_global.opacity_flag -> idopt:Names.lident option -> Proof_global.t option + +val save_pstate_proved + : pstate:Proof_global.pstate + -> opaque:Proof_global.opacity_flag + -> idopt:Names.lident option + -> unit diff --git a/vernac/obligations.ml b/vernac/obligations.ml index bc741a0ec7..0d93e19723 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -760,7 +760,7 @@ let update_obls prg obls rem = match prg'.prg_deps with | [] -> let kn = declare_definition prg' in - progmap_remove prg'; + progmap_remove prg'; Defined kn | l -> let progs = List.map (fun x -> get_info (ProgMap.find x !from_prg)) prg'.prg_deps in @@ -944,7 +944,7 @@ let obligation_hook prg obl num auto ctx' _ _ gr = ignore (auto (Some prg.prg_name) None deps) end -let rec solve_obligation ~ontop prg num tac = +let rec solve_obligation prg num tac = let user_num = succ num in let obls, rem = prg.prg_obligations in let obl = obls.(num) in @@ -965,19 +965,19 @@ let rec solve_obligation ~ontop prg num tac = Proof_global.make_terminator (obligation_terminator prg.prg_name num guard ?hook auto) in let hook = Lemmas.mk_hook (obligation_hook prg obl num auto) in - let pstate = Lemmas.start_proof ~ontop ~sign:prg.prg_sign obl.obl_name kind evd (EConstr.of_constr obl.obl_type) ~terminator ~hook in + let pstate = Lemmas.start_proof ~sign:prg.prg_sign obl.obl_name kind evd (EConstr.of_constr obl.obl_type) ~terminator ~hook in let pstate = fst @@ Pfedit.by !default_tactic pstate in let pstate = Option.cata (fun tac -> Proof_global.set_endline_tactic tac pstate) pstate tac in pstate -and obligation ~ontop (user_num, name, typ) tac = +and obligation (user_num, name, typ) tac = let num = pred user_num in let prg = get_prog_err name in let obls, rem = prg.prg_obligations in if num >= 0 && num < Array.length obls then let obl = obls.(num) in match obl.obl_body with - | None -> solve_obligation ~ontop prg num tac + | None -> solve_obligation prg num tac | Some r -> error "Obligation already solved" else error (sprintf "Unknown obligation number %i" (succ num)) @@ -1177,7 +1177,7 @@ let admit_obligations n = let prg = get_prog_err n in admit_prog prg -let next_obligation ~ontop n tac = +let next_obligation n tac = let prg = match n with | None -> get_any_prog_err () | Some _ -> get_prog_err n @@ -1188,7 +1188,7 @@ let next_obligation ~ontop n tac = | Some i -> i | None -> anomaly (Pp.str "Could not find a solvable obligation.") in - solve_obligation ~ontop prg i tac + solve_obligation prg i tac let check_program_libraries () = Coqlib.check_required_library Coqlib.datatypes_module_name; diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 9214ddd4b9..7db094a75d 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -86,16 +86,14 @@ val add_mutual_definitions : fixpoint_kind -> unit val obligation - : ontop:Proof_global.t option - -> int * Names.Id.t option * Constrexpr.constr_expr option + : int * Names.Id.t option * Constrexpr.constr_expr option -> Genarg.glob_generic_argument option - -> Proof_global.t + -> Proof_global.pstate val next_obligation - : ontop:Proof_global.t option - -> Names.Id.t option + : Names.Id.t option -> Genarg.glob_generic_argument option - -> Proof_global.t + -> Proof_global.pstate val solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> progress (* Number of remaining obligations to be solved for this program *) diff --git a/vernac/search.mli b/vernac/search.mli index 0f94ddc5b6..f8074a67ff 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -39,13 +39,13 @@ val search_about_filter : glob_search_about_item -> filter_function goal and the global environment for things matching [pattern] and satisfying module exclude/include clauses of [modinout]. *) -val search_by_head : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool +val search_by_head : ?pstate:Proof_global.pstate -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_rewrite : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool +val search_rewrite : ?pstate:Proof_global.pstate -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_pattern : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool +val search_pattern : ?pstate:Proof_global.pstate -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_about : ?pstate:Proof_global.t -> int option -> (bool * glob_search_about_item) list +val search_about : ?pstate:Proof_global.pstate -> int option -> (bool * glob_search_about_item) list -> DirPath.t list * bool -> display_function -> unit type search_constraint = @@ -66,12 +66,12 @@ type 'a coq_object = { coq_object_object : 'a; } -val interface_search : ?pstate:Proof_global.t -> ?glnum:int -> (search_constraint * bool) list -> +val interface_search : ?pstate:Proof_global.pstate -> ?glnum:int -> (search_constraint * bool) list -> constr coq_object list (** {6 Generic search function} *) -val generic_search : ?pstate:Proof_global.t -> int option -> display_function -> unit +val generic_search : ?pstate:Proof_global.pstate -> int option -> display_function -> unit (** This function iterates over all hypothesis of the goal numbered [glnum] (if present) and all known declarations. *) diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 337cb233a2..f92c1f9c27 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -56,6 +56,10 @@ let vernac_require_open_proof ~pstate f = | Some pstate -> f ~pstate | None -> user_err Pp.(str "Command not supported (No proof-editing in progress)") +let with_pstate ~pstate f = + vernac_require_open_proof ~pstate + (fun ~pstate -> f ~pstate:(Proof_global.get_current_pstate pstate)) + let get_current_or_global_context ~pstate = match pstate with | None -> let env = Global.env () in Evd.(from_env env, env) @@ -540,7 +544,7 @@ let () = (***********) (* Gallina *) -let start_proof_and_print ~program_mode ~pstate ?hook k l = +let start_proof_and_print ~program_mode ?hook k l = let inference_hook = if program_mode then let hook env sigma ev = @@ -562,7 +566,7 @@ let start_proof_and_print ~program_mode ~pstate ?hook k l = in Some hook else None in - start_proof_com ~program_mode ~ontop:pstate ?inference_hook ?hook k l + start_proof_com ~program_mode ?inference_hook ?hook k l let vernac_definition_hook p = function | Coercion -> @@ -573,7 +577,7 @@ let vernac_definition_hook p = function Some (Class.add_subclass_hook p) | _ -> None -let vernac_definition ~atts ~pstate discharge kind ({loc;v=id}, pl) def = +let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def ~pstate = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in let hook = vernac_definition_hook atts.polymorphic kind in @@ -593,9 +597,10 @@ let vernac_definition ~atts ~pstate discharge kind ({loc;v=id}, pl) def = in (match def with | ProveBody (bl,t) -> (* local binders, typ *) - Some (start_proof_and_print ~program_mode ~pstate (local, atts.polymorphic, DefinitionBody kind) + Some (start_proof_and_print ~program_mode (local, atts.polymorphic, DefinitionBody kind) ?hook [(CAst.make ?loc name, pl), (bl, t)]) | DefineBody (bl,red_option,c,typ_opt) -> + let pstate = Option.map Proof_global.get_current_pstate pstate in let red_option = match red_option with | None -> None | Some r -> @@ -603,30 +608,31 @@ let vernac_definition ~atts ~pstate discharge kind ({loc;v=id}, pl) def = Some (snd (Hook.get f_interp_redexp env sigma r)) in ComDefinition.do_definition ~program_mode name (local, atts.polymorphic, kind) pl bl red_option c typ_opt ?hook; - pstate + None ) -let vernac_start_proof ~atts ~pstate kind l = +(* NB: pstate argument to use combinators easily *) +let vernac_start_proof ~atts kind l ~pstate = let open DefAttributes in let local = enforce_locality_exp atts.locality NoDischarge in if Dumpglob.dump () then List.iter (fun ((id, _), _) -> Dumpglob.dump_definition id false "prf") l; - Some (start_proof_and_print ~pstate ~program_mode:atts.program (local, atts.polymorphic, Proof kind) l) + Some (start_proof_and_print ~program_mode:atts.program (local, atts.polymorphic, Proof kind) l) -let vernac_end_proof ?pstate ?proof = function +let vernac_end_proof ?pstate:ontop ?proof = function | Admitted -> - vernac_require_open_proof ~pstate (save_proof_admitted ?proof); - pstate + with_pstate ~pstate:ontop (save_proof_admitted ?proof); + ontop | Proved (opaque,idopt) -> - save_proof_proved ?pstate ?proof ~opaque ~idopt + save_proof_proved ?ontop ?proof ~opaque ~idopt -let vernac_exact_proof ~pstate c = +let vernac_exact_proof ~pstate:ontop c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the beginning of a proof. *) - let pstate, status = Pfedit.by (Tactics.exact_proof c) pstate in - let pstate = save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Opaque ~idopt:None in + let pstate, status = Pfedit.by (Tactics.exact_proof c) (Proof_global.get_current_pstate ontop) in + let () = save_pstate_proved ~pstate ~opaque:Proof_global.Opaque ~idopt:None in if not status then Feedback.feedback Feedback.AddedAxiom; - pstate + Proof_global.discard_current ontop let vernac_assumption ~atts discharge kind l nl = let open DefAttributes in @@ -804,7 +810,7 @@ let vernac_inductive ~atts cum lo finite indl = in vernac_record cum (Class true) atts.polymorphic finite [id, bl, c, None, [f]] *) -let vernac_fixpoint ~atts ~pstate discharge l : Proof_global.t option = +let vernac_fixpoint ~atts discharge l ~pstate = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then @@ -813,11 +819,11 @@ let vernac_fixpoint ~atts ~pstate discharge l : Proof_global.t option = let do_fixpoint = if atts.program then fun local sign l -> ComProgramFixpoint.do_fixpoint local sign l; None else - ComFixpoint.do_fixpoint ~ontop:pstate + ComFixpoint.do_fixpoint in do_fixpoint local atts.polymorphic l -let vernac_cofixpoint ~atts ~pstate discharge l = +let vernac_cofixpoint ~atts discharge l ~pstate = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then @@ -825,7 +831,7 @@ let vernac_cofixpoint ~atts ~pstate discharge l = let do_cofixpoint = if atts.program then fun local sign l -> ComProgramFixpoint.do_cofixpoint local sign l; None else - ComFixpoint.do_cofixpoint ~ontop:pstate + ComFixpoint.do_cofixpoint in do_cofixpoint local atts.polymorphic l @@ -1104,7 +1110,7 @@ let vernac_set_end_tac ~pstate tac = (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) Proof_global.set_endline_tactic tac pstate -let vernac_set_used_variables ~(pstate : Proof_global.t) e : Proof_global.t = +let vernac_set_used_variables ~(pstate : Proof_global.pstate) e : Proof_global.pstate = let env = Global.env () in let initial_goals pf = Proofview.initial_goals Proof.(data pf).Proof.entry in let tys = @@ -1118,9 +1124,7 @@ let vernac_set_used_variables ~(pstate : Proof_global.t) e : Proof_global.t = (str "Unknown variable: " ++ Id.print id)) l; let _, pstate = Proof_global.set_used_variables pstate l in - fst @@ Proof_global.with_current_proof begin fun _ p -> - (p, ()) - end pstate + pstate (*****************************) (* Auxiliary file management *) @@ -1829,6 +1833,7 @@ let query_command_selector ?loc = function (str "Query commands only support the single numbered goal selector.") let vernac_check_may_eval ~pstate ~atts redexp glopt rc = + let pstate = Option.map Proof_global.get_current_pstate pstate in let glopt = query_command_selector glopt in let sigma, env = get_current_context_of_args ~pstate glopt in let sigma, c = interp_open_constr env sigma rc in @@ -1929,6 +1934,7 @@ let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = print_about env sigma ref_or_by_not udecl let vernac_print ~(pstate : Proof_global.t option) ~atts = + let pstate = Option.map Proof_global.get_current_pstate pstate in let sigma, env = get_current_or_global_context ~pstate in function | PrintTables -> print_tables () @@ -2040,6 +2046,7 @@ let () = optwrite = (:=) search_output_name_only } let vernac_search ~pstate ~atts s gopt r = + let pstate = Option.map Proof_global.get_current_pstate pstate in let gopt = query_command_selector gopt in let r = interp_search_restriction r in let env,gopt = @@ -2077,6 +2084,7 @@ let vernac_locate ~pstate = function | LocateTerm {v=AN qid} -> print_located_term qid | LocateAny {v=ByNotation (ntn, sc)} (* TODO : handle Ltac notations *) | LocateTerm {v=ByNotation (ntn, sc)} -> + let pstate = Option.map Proof_global.get_current_pstate pstate in let _, env = get_current_or_global_context ~pstate in Notation.locate_notation (Constrextern.without_symbols (pr_lglob_constr_env env)) ntn sc @@ -2132,6 +2140,7 @@ let vernac_unfocus () = (* Checks that a proof is fully unfocused. Raises an error if not. *) let vernac_unfocused ~pstate = + let pstate = Proof_global.get_current_pstate pstate in let p = Proof_global.give_me_the_proof pstate in if Proof.unfocused p then str"The proof is indeed fully unfocused." @@ -2162,18 +2171,19 @@ let vernac_bullet (bullet : Proof_bullet.t) = Proof_global.simple_with_current_proof (fun _ p -> Proof_bullet.put p bullet) -let vernac_show ~pstate = - match pstate with +let vernac_show ~pstate:ontop = + match ontop with (* Show functions that don't require a proof state *) | None -> begin function - | ShowProof -> show_proof ~pstate + | ShowProof -> show_proof ~pstate:None | ShowMatch id -> show_match id | _ -> user_err (str "This command requires an open proof.") end (* Show functions that require a proof state *) - | Some pstate -> + | Some ontop -> + let pstate = Proof_global.get_current_pstate ontop in begin function | ShowGoal goalref -> let proof = Proof_global.give_me_the_proof pstate in @@ -2185,7 +2195,7 @@ let vernac_show ~pstate = | ShowExistentials -> show_top_evars ~pstate | ShowUniverses -> show_universes ~pstate | ShowProofNames -> - pr_sequence Id.print (Proof_global.get_all_proof_names pstate) + pr_sequence Id.print (Proof_global.get_all_proof_names ontop) | ShowIntros all -> show_intro ~pstate all | ShowProof -> show_proof ~pstate:(Some pstate) | ShowMatch id -> show_match id @@ -2223,6 +2233,10 @@ let with_def_attributes ~atts f = if atts.DefAttributes.program then Obligations.check_program_libraries (); f ~atts +let with_maybe_open_proof ~pstate f = + let opt = f ~pstate in + Proof_global.maybe_push ~ontop:pstate opt + (** A global default timeout, controlled by option "Set Default Timeout n". Use "Unset Default Timeout" to deactivate it (or set it to 0). *) @@ -2339,9 +2353,9 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.t option = (* Gallina *) | VernacDefinition ((discharge,kind),lid,d) -> - with_def_attributes ~atts vernac_definition ~pstate discharge kind lid d + with_maybe_open_proof ~pstate (with_def_attributes ~atts vernac_definition discharge kind lid d) | VernacStartTheoremProof (k,l) -> - with_def_attributes ~atts vernac_start_proof ~pstate k l + with_maybe_open_proof ~pstate (with_def_attributes ~atts vernac_start_proof k l) | VernacEndProof e -> unsupported_attributes atts; vernac_end_proof ?proof ?pstate e @@ -2355,9 +2369,9 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.t option = vernac_inductive ~atts cum priv finite l; pstate | VernacFixpoint (discharge, l) -> - with_def_attributes ~atts vernac_fixpoint ~pstate discharge l + with_maybe_open_proof ~pstate (with_def_attributes ~atts vernac_fixpoint discharge l) | VernacCoFixpoint (discharge, l) -> - with_def_attributes ~atts vernac_cofixpoint ~pstate discharge l + with_maybe_open_proof ~pstate (with_def_attributes ~atts vernac_cofixpoint discharge l) | VernacScheme l -> unsupported_attributes atts; vernac_scheme l; @@ -2587,7 +2601,7 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.t option = | VernacCheckGuard -> unsupported_attributes atts; Feedback.msg_notice @@ - vernac_require_open_proof ~pstate (vernac_check_guard); + with_pstate ~pstate (vernac_check_guard); pstate | VernacProof (tac, using) -> unsupported_attributes atts; @@ -2596,10 +2610,14 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.t option = let usings = if Option.is_empty using then "using:no" else "using:yes" in Aux_file.record_in_aux_at "VernacProof" (tacs^" "^usings); let pstate = - vernac_require_open_proof ~pstate (fun ~pstate -> + vernac_require_open_proof ~pstate (fun ~pstate:ontop -> + Proof_global.modify_current_pstate (fun pstate -> + let pstate = Proof_global.get_current_pstate ontop in let pstate = Option.cata (vernac_set_end_tac ~pstate) pstate tac in Option.cata (vernac_set_used_variables ~pstate) pstate using) - in Some pstate + ontop) + in + Some pstate | VernacProofMode mn -> unsupported_attributes atts; pstate diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index 77f54361da..9ab2d00fc2 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -96,17 +96,21 @@ module Proof_global = struct | None -> raise NoCurrentProof | Some x -> f x + let cc1 f = cc (fun p -> f (Proof_global.get_current_pstate p)) + let dd f = match !s_proof with | None -> raise NoCurrentProof | Some x -> s_proof := Some (f x) + let dd1 f = dd (fun p -> Proof_global.modify_current_pstate f p) + let there_are_pending_proofs () = !s_proof <> None - let get_open_goals () = cc get_open_goals + let get_open_goals () = cc1 get_open_goals - let set_terminator x = dd (set_terminator x) - let give_me_the_proof_opt () = Option.map give_me_the_proof !s_proof - let give_me_the_proof () = cc give_me_the_proof - let get_current_proof_name () = cc get_current_proof_name + let set_terminator x = dd1 (set_terminator x) + let give_me_the_proof_opt () = Option.map (fun p -> give_me_the_proof (Proof_global.get_current_pstate p)) !s_proof + let give_me_the_proof () = cc1 give_me_the_proof + let get_current_proof_name () = cc1 get_current_proof_name let simple_with_current_proof f = dd (simple_with_current_proof f) @@ -118,18 +122,18 @@ module Proof_global = struct let install_state s = s_proof := Some s let return_proof ?allow_partial () = - cc (return_proof ?allow_partial) + cc1 (return_proof ?allow_partial) let close_future_proof ~opaque ~feedback_id pf = - cc (fun st -> close_future_proof ~opaque ~feedback_id st pf) + cc1 (fun st -> close_future_proof ~opaque ~feedback_id st pf) let close_proof ~opaque ~keep_body_ucst_separate f = - cc (close_proof ~opaque ~keep_body_ucst_separate f) + cc1 (close_proof ~opaque ~keep_body_ucst_separate f) let discard_all () = s_proof := None - let update_global_env () = dd update_global_env + let update_global_env () = dd1 update_global_env - let get_current_context () = cc Pfedit.get_current_context + let get_current_context () = cc1 Pfedit.get_current_context let get_all_proof_names () = try cc get_all_proof_names -- cgit v1.2.3 From b8842c3c8d6e6d9d4c19a75453fca9f94de6fa49 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Fri, 3 May 2019 14:14:40 +0200 Subject: coqpp: add new ![] specifiers for structured proof interaction ![proof_stack] is equivalent to the old meaning of ![proof]: the body has type `pstate:Proof_global.t option -> Proof_global.t option` The other specifiers are for the following body types: ~~~ ![open_proof] `is_ontop:bool -> pstate` ![maybe_open_proof] `is_ontop:bool -> pstate option` ![proof] `pstate:pstate -> pstate` ![proof_opt_query] `pstate:pstate option -> unit` ![proof_query] `pstate:pstate -> unit` ~~~ The `is_ontop` is only used for the warning message when declaring a section variable inside a proof, we could also just stop warning. The specifiers look closely related to stm classifiers, but currently they're unconnected. Notably this means that a ![proof_query] doesn't have to be classified QUERY. ![proof_stack] is only used by g_rewrite/rewrite whose behaviour I don't fully understand, maybe we can drop it in the future. For compat we may want to consider keeping ![proof] with its old meaning and using some new name for the new meaning. OTOH fixing plugins to be stricter is easier if we change it as the errors tell us where it's used. --- coqpp/coqpp_main.ml | 21 +++++++++- doc/plugin_tutorial/tuto1/src/g_tuto1.mlg | 16 ++++---- plugins/derive/g_derive.mlg | 4 +- plugins/extraction/g_extraction.mlg | 10 +---- plugins/funind/g_indfun.mlg | 25 +++++------- plugins/funind/indfun.ml | 11 ++--- plugins/funind/indfun.mli | 2 +- plugins/ltac/extratactics.mlg | 6 +-- plugins/ltac/g_ltac.mlg | 8 ++-- plugins/ltac/g_obligations.mlg | 16 ++++---- plugins/ltac/g_rewrite.mlg | 55 +++++++++++-------------- plugins/ltac/rewrite.ml | 67 +++++++++++++++---------------- plugins/ltac/rewrite.mli | 35 +++++++++++----- user-contrib/Ltac2/g_ltac2.mlg | 34 ++++++---------- user-contrib/Ltac2/tac2entries.ml | 5 +-- user-contrib/Ltac2/tac2entries.mli | 5 ++- user-contrib/Ltac2/tac2expr.mli | 2 - vernac/classes.ml | 15 +++---- vernac/classes.mli | 5 +-- vernac/vernacentries.ml | 11 +++-- vernac/vernacentries.mli | 4 ++ vernac/vernacstate.ml | 2 + vernac/vernacstate.mli | 2 + 23 files changed, 188 insertions(+), 173 deletions(-) diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 42fe13e4eb..8444f3a58c 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -359,10 +359,29 @@ let print_atts_right fmt = function let print_body_wrapper fmt r = match r.vernac_state with - | Some "proof" -> + | Some "proof_stack" -> fprintf fmt "let proof = (%a) ~pstate:st.Vernacstate.proof in { st with Vernacstate.proof }" print_code r.vernac_body + + | Some "open_proof" -> + let push = "Some (Proof_global.push ~ontop:st.Vernacstate.proof pstate)" in + fprintf fmt "let pstate = (%a) in let proof = %s in { st with Vernacstate.proof }" print_code r.vernac_body push + + | Some "maybe_open_proof" -> + let push = "Proof_global.maybe_push ~ontop:st.Vernacstate.proof pstate" in + fprintf fmt "let pstate = (%a) in let proof = %s in { st with Vernacstate.proof }" print_code r.vernac_body push + + | Some "proof" -> + fprintf fmt "let proof = Vernacentries.modify_pstate ~pstate:st.Vernacstate.proof (%a) in { st with Vernacstate.proof }" print_code r.vernac_body + + | Some "proof_opt_query" -> + fprintf fmt "let () = (%a) ~pstate:(Vernacstate.pstate st) in st" print_code r.vernac_body + + | Some "proof_query" -> + fprintf fmt "let () = Vernacentries.with_pstate ~pstate:st.Vernacstate.proof (%a) in st" print_code r.vernac_body + | None -> fprintf fmt "let () = %a in st" print_code r.vernac_body + | Some x -> fatal ("unsupported state specifier: " ^ x) diff --git a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg index 147b0df567..300d62285a 100644 --- a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg +++ b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg @@ -145,13 +145,11 @@ END it gives an error message that is basically impossible to understand. *) VERNAC COMMAND EXTEND ExploreProof CLASSIFIED AS QUERY -| ![ proof ] [ "Cmd9" ] -> - { fun ~pstate:ontop -> - Option.iter (fun ontop -> - let pstate = Proof_global.get_current_pstate ontop in - let sigma, env = Pfedit.get_current_context pstate in - let pprf = Proof.partial_proof Proof_global.(give_me_the_proof pstate) in - Feedback.msg_notice - (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf)) ontop; - ontop } +| ![ proof_query ] [ "Cmd9" ] -> + { fun ~pstate -> + let sigma, env = Pfedit.get_current_context pstate in + let pprf = Proof.partial_proof Proof_global.(give_me_the_proof pstate) in + Feedback.msg_notice + (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf) + } END diff --git a/plugins/derive/g_derive.mlg b/plugins/derive/g_derive.mlg index ee076f5ae3..d25b8fd01c 100644 --- a/plugins/derive/g_derive.mlg +++ b/plugins/derive/g_derive.mlg @@ -23,6 +23,6 @@ let classify_derive_command _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpac } VERNAC COMMAND EXTEND Derive CLASSIFIED BY { classify_derive_command } -| ![ proof ] [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> - { fun ~pstate -> Some (Proof_global.push ~ontop:pstate Derive.(start_deriving f suchthat lemma)) } +| ![ open_proof ] [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> + { Derive.(start_deriving f suchthat lemma) } END diff --git a/plugins/extraction/g_extraction.mlg b/plugins/extraction/g_extraction.mlg index d43d90af60..487accbc9b 100644 --- a/plugins/extraction/g_extraction.mlg +++ b/plugins/extraction/g_extraction.mlg @@ -178,12 +178,6 @@ END (* Show the extraction of the current proof *) VERNAC COMMAND EXTEND ShowExtraction CLASSIFIED AS QUERY -| ![ proof ] [ "Show" "Extraction" ] - -> { fun ~pstate:ontop -> - let pstate = Option.map Proof_global.get_current_pstate ontop in - let pstate = match pstate with - | None -> CErrors.user_err Pp.(str "No ongoing proof") - | Some pstate -> pstate - in - let () = show_extraction ~pstate in ontop } +| ![ proof_query ] [ "Show" "Extraction" ] + -> { show_extraction } END diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index b8db3dc5ce..cc772e96f3 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -177,7 +177,7 @@ let () = (* TASSI: n'importe quoi ! *) VERNAC COMMAND EXTEND Function -| ![ proof ] ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] +| ![ maybe_open_proof ] ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] => { let hard = List.exists (function | _,((_,(Some { CAst.v = CMeasureRec _ } | Some { CAst.v = CWfRec _}),_,_,_),_) -> true @@ -190,9 +190,7 @@ VERNAC COMMAND EXTEND Function | Vernacextend.VtSideff ids, _ when hard -> Vernacextend.(VtStartProof (GuaranteesOpacity, ids), VtLater) | x -> x } - -> { fun ~pstate:ontop -> - let pstate = do_generate_principle false (List.map snd recsl) in - Proof_global.maybe_push ~ontop pstate} + -> { do_generate_principle false (List.map snd recsl) } END { @@ -227,33 +225,32 @@ let warning_error names e = } VERNAC COMMAND EXTEND NewFunctionalScheme -| ![ proof ] ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] +| ![ maybe_open_proof ] ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] => { Vernacextend.(VtSideff(List.map pi1 fas), VtLater) } -> - { fun ~pstate:ontop -> - begin + { begin try - Functional_principles_types.build_scheme fas; ontop + Functional_principles_types.build_scheme fas; None with | Functional_principles_types.No_graph_found -> begin match fas with | (_,fun_name,_)::_ -> begin - let ontop = make_graph ~ontop (Smartlocate.global_with_alias fun_name) in - try Functional_principles_types.build_scheme fas; ontop + let pstate = make_graph (Smartlocate.global_with_alias fun_name) in + try Functional_principles_types.build_scheme fas; pstate with | Functional_principles_types.No_graph_found -> CErrors.user_err Pp.(str "Cannot generate induction principle(s)") | e when CErrors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in - warning_error names e; ontop + warning_error names e; pstate end | _ -> assert false (* we can only have non empty list *) end | e when CErrors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in - warning_error names e; ontop + warning_error names e; None end } END @@ -267,6 +264,6 @@ END (***** debug only ***) VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY -| ![ proof ] ["Generate" "graph" "for" reference(c)] -> - { fun ~pstate:ontop -> make_graph ~ontop (Smartlocate.global_with_alias c) } +| ![ maybe_open_proof ] ["Generate" "graph" "for" reference(c)] -> + { make_graph (Smartlocate.global_with_alias c) } END diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index d47c12a7cb..6ea2eb579f 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -839,7 +839,9 @@ let rec get_args b t : Constrexpr.local_binder_expr list * | _ -> [],b,t -let make_graph env sigma (f_ref : GlobRef.t) = +let make_graph (f_ref : GlobRef.t) = + let env = Global.env() in + let sigma = Evd.from_env env in let c,c_body = match f_ref with | ConstRef c -> @@ -907,11 +909,4 @@ let make_graph env sigma (f_ref : GlobRef.t) = expr_list; pstate) -let make_graph ~ontop f_ref = - let pstate = Option.map Proof_global.get_current_pstate ontop in - let sigma, env = Option.cata Pfedit.get_current_context - (let e = Global.env () in Evd.from_env e, e) pstate in - Option.cata (fun ps -> Some (Proof_global.push ~ontop ps)) ontop - (make_graph env sigma f_ref) - let do_generate_principle = do_generate_principle [] warning_error true diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index cf4ef23d1a..c803484617 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -17,4 +17,4 @@ val functional_induction : Ltac_plugin.Tacexpr.or_and_intro_pattern option -> Goal.goal Evd.sigma -> Goal.goal list Evd.sigma -val make_graph : ontop:Proof_global.t option -> GlobRef.t -> Proof_global.t option +val make_graph : GlobRef.t -> Proof_global.pstate option diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 5e4969567d..4a2fb425ac 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -934,7 +934,7 @@ END VERNAC COMMAND EXTEND GrabEvars | ![ proof ] [ "Grab" "Existential" "Variables" ] => { classify_as_proofstep } - -> { fun ~pstate -> Option.map (Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p)) pstate } + -> { fun ~pstate -> Proof_global.modify_proof (fun p -> Proof.V82.grab_evars p) pstate } END (* Shelves all the goals under focus. *) @@ -966,7 +966,7 @@ END VERNAC COMMAND EXTEND Unshelve | ![ proof ] [ "Unshelve" ] => { classify_as_proofstep } - -> { fun ~pstate -> Option.map (Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p)) pstate } + -> { fun ~pstate -> Proof_global.modify_proof (fun p -> Proof.unshelve p) pstate } END (* Gives up on the goals under focus: the goals are considered solved, @@ -1118,7 +1118,7 @@ END VERNAC COMMAND EXTEND OptimizeProof | ![ proof ] [ "Optimize" "Proof" ] => { classify_as_proofstep } -> - { fun ~pstate -> Option.map Proof_global.(modify_current_pstate compact_the_proof) pstate } + { fun ~pstate -> Proof_global.compact_the_proof pstate } | [ "Optimize" "Heap" ] => { classify_as_proofstep } -> { Gc.compact () } END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 7eb34158e8..9bf5bd1bda 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -376,7 +376,7 @@ let () = declare_int_option { let vernac_solve ~pstate n info tcom b = let open Goal_select in - let pstate, status = Proof_global.with_current_proof (fun etac p -> + let pstate, status = Proof_global.with_proof (fun etac p -> let with_end_tac = if b then Some etac else None in let global = match n with SelectAll | SelectList _ -> true | _ -> false in let info = Option.append info !print_info_trace in @@ -388,7 +388,7 @@ let vernac_solve ~pstate n info tcom b = let p = Proof.maximal_unfocus Vernacentries.command_focus p in p,status) pstate in if not status then Feedback.feedback Feedback.AddedAxiom; - Some pstate + pstate let pr_ltac_selector s = Pptactic.pr_goal_selector ~toplevel:true s @@ -438,7 +438,7 @@ VERNAC { tactic_mode } EXTEND VernacSolve | ![ proof ] [ ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => { classify_as_proofstep } -> { let g = Option.default (Goal_select.get_default_goal_selector ()) g in - Vernacentries.vernac_require_open_proof vernac_solve g n t def + vernac_solve g n t def } | ![ proof ] [ "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => { @@ -450,7 +450,7 @@ VERNAC { tactic_mode } EXTEND VernacSolve VtLater } -> { let t = rm_abstract t in - Vernacentries.vernac_require_open_proof vernac_solve Goal_select.SelectAll n t def + vernac_solve Goal_select.SelectAll n t def } END diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index d7918a58ac..c01b97c14d 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -80,25 +80,25 @@ GRAMMAR EXTEND Gram open Obligations -let obligation ~pstate obl tac = Some (Proof_global.push ~ontop:pstate (with_tac (fun t -> Obligations.obligation obl t) tac)) -let next_obligation ~pstate obl tac = Some (Proof_global.push ~ontop:pstate (with_tac (fun t -> Obligations.next_obligation obl t) tac)) +let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac +let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac let classify_obbl _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[]), VtLater) } VERNAC COMMAND EXTEND Obligations CLASSIFIED BY { classify_obbl } -| ![ proof ] [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> +| ![ open_proof ] [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> { obligation (num, Some name, Some t) tac } -| ![ proof ] [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> +| ![ open_proof ] [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> { obligation (num, Some name, None) tac } -| ![ proof ] [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> +| ![ open_proof ] [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> { obligation (num, None, Some t) tac } -| ![ proof ] [ "Obligation" integer(num) withtac(tac) ] -> +| ![ open_proof ] [ "Obligation" integer(num) withtac(tac) ] -> { obligation (num, None, None) tac } -| ![ proof ] [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> +| ![ open_proof ] [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> { next_obligation (Some name) tac } -| ![ proof ] [ "Next" "Obligation" withtac(tac) ] -> { next_obligation None tac } +| ![ open_proof ] [ "Next" "Obligation" withtac(tac) ] -> { next_obligation None tac } END VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index e3f4b8ef59..bb29323858 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -180,34 +180,34 @@ TACTIC EXTEND setoid_rewrite END VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> { declare_relation atts a aeq n (Some lemma1) (Some lemma2) None } - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> { declare_relation atts a aeq n (Some lemma1) None None } - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> { declare_relation atts a aeq n None None None } END VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> { declare_relation atts a aeq n None (Some lemma2) None } - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts a aeq n None (Some lemma2) (Some lemma3) } END VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts a aeq n (Some lemma1) None (Some lemma3) } - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts a aeq n None None (Some lemma3) } END @@ -234,66 +234,59 @@ GRAMMAR EXTEND Gram END VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n (Some lemma1) (Some lemma2) None } - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n (Some lemma1) None None } - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n None None None } END VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n None (Some lemma2) None } - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n None (Some lemma2) (Some lemma3) } END VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n (Some lemma1) None (Some lemma3) } - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n None None (Some lemma3) } END VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> { add_setoid atts [] a aeq t n } - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> { add_setoid atts binders a aeq t n } - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Morphism" constr(m) ":" ident(n) ] + | #[ atts = rewrite_attributes; ] ![ maybe_open_proof ] [ "Add" "Morphism" constr(m) ":" ident(n) ] (* This command may or may not open a goal *) => { (if Lib.is_modtype() then VtSideff([n]) else VtStartProof(GuaranteesOpacity, [n])), VtLater } - -> { - fun ~pstate:ontop -> - Option.cata (fun ps -> Some (Proof_global.push ~ontop ps)) ontop (add_morphism_infer atts m n) - } - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] + -> { add_morphism_infer atts m n } + | #[ atts = rewrite_attributes; ] ![ open_proof ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] => { VtStartProof(GuaranteesOpacity,[n]), VtLater } - -> { - add_morphism atts [] m s n - } - | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) + -> { add_morphism atts [] m s n } + | #[ atts = rewrite_attributes; ] ![ open_proof ] [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] => { VtStartProof(GuaranteesOpacity,[n]), VtLater } - -> { - add_morphism atts binders m s n - } + -> { add_morphism atts binders m s n } END TACTIC EXTEND setoid_symmetry diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index efca411754..5d57a2f27f 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -23,7 +23,6 @@ open Tacticals.New open Tactics open Pretype_errors open Typeclasses -open Classes open Constrexpr open Globnames open Evd @@ -1795,17 +1794,17 @@ let declare_an_instance n s args = let declare_instance a aeq n s = declare_an_instance n s [a;aeq] -let anew_instance ~pstate atts binders (name,t) fields = +let anew_instance atts binders (name,t) fields = let program_mode = atts.program in - let _id, pstate = new_instance ~pstate ~program_mode atts.polymorphic + let _id, proof = Classes.new_instance ~program_mode atts.polymorphic name binders t (Some (true, CAst.make @@ CRecord (fields))) ~global:atts.global ~generalize:false Hints.empty_hint_info in - pstate + assert (Option.is_empty proof) (* refine:false with term *) -let declare_instance_refl ~pstate atts binders a aeq n lemma = +let declare_instance_refl atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" - in anew_instance ~pstate atts binders instance + in anew_instance atts binders instance [(qualid_of_ident (Id.of_string "reflexivity"),lemma)] let declare_instance_sym atts binders a aeq n lemma = @@ -1818,41 +1817,41 @@ let declare_instance_trans atts binders a aeq n lemma = in anew_instance atts binders instance [(qualid_of_ident (Id.of_string "transitivity"),lemma)] -let declare_relation ~pstate atts ?(binders=[]) a aeq n refl symm trans = +let declare_relation atts ?(binders=[]) a aeq n refl symm trans = init_setoid (); let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" in - let pstate = anew_instance ~pstate atts binders instance [] in + let () = anew_instance atts binders instance [] in match (refl,symm,trans) with - (None, None, None) -> pstate + (None, None, None) -> () | (Some lemma1, None, None) -> - declare_instance_refl ~pstate atts binders a aeq n lemma1 + declare_instance_refl atts binders a aeq n lemma1 | (None, Some lemma2, None) -> - declare_instance_sym ~pstate atts binders a aeq n lemma2 + declare_instance_sym atts binders a aeq n lemma2 | (None, None, Some lemma3) -> - declare_instance_trans ~pstate atts binders a aeq n lemma3 + declare_instance_trans atts binders a aeq n lemma3 | (Some lemma1, Some lemma2, None) -> - let pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in - declare_instance_sym ~pstate atts binders a aeq n lemma2 + let () = declare_instance_refl atts binders a aeq n lemma1 in + declare_instance_sym atts binders a aeq n lemma2 | (Some lemma1, None, Some lemma3) -> - let pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in - let pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let () = declare_instance_refl atts binders a aeq n lemma1 in + let () = declare_instance_trans atts binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in - anew_instance ~pstate atts binders instance + anew_instance atts binders instance [(qualid_of_ident (Id.of_string "PreOrder_Reflexive"), lemma1); (qualid_of_ident (Id.of_string "PreOrder_Transitive"),lemma3)] | (None, Some lemma2, Some lemma3) -> - let pstate = declare_instance_sym ~pstate atts binders a aeq n lemma2 in - let pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let () = declare_instance_sym atts binders a aeq n lemma2 in + let () = declare_instance_trans atts binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in - anew_instance ~pstate atts binders instance + anew_instance atts binders instance [(qualid_of_ident (Id.of_string "PER_Symmetric"), lemma2); (qualid_of_ident (Id.of_string "PER_Transitive"),lemma3)] | (Some lemma1, Some lemma2, Some lemma3) -> - let pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in - let pstate = declare_instance_sym ~pstate atts binders a aeq n lemma2 in - let pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let () = declare_instance_refl atts binders a aeq n lemma1 in + let () = declare_instance_sym atts binders a aeq n lemma2 in + let () = declare_instance_trans atts binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in - anew_instance ~pstate atts binders instance + anew_instance atts binders instance [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), lemma1); (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), lemma2); (qualid_of_ident (Id.of_string "Equivalence_Transitive"), lemma3)] @@ -1951,15 +1950,15 @@ let warn_add_setoid_deprecated = CWarnings.create ~name:"add-setoid" ~category:"deprecated" (fun () -> Pp.(str "Add Setoid is deprecated, please use Add Parametric Relation.")) -let add_setoid ~pstate atts binders a aeq t n = +let add_setoid atts binders a aeq t n = warn_add_setoid_deprecated ?loc:a.CAst.loc (); init_setoid (); - let pstate = declare_instance_refl ~pstate atts binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in - let pstate = declare_instance_sym ~pstate atts binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in - let pstate = declare_instance_trans ~pstate atts binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in + let () = declare_instance_refl atts binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in + let () = declare_instance_sym atts binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in + let () = declare_instance_trans atts binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in - anew_instance ~pstate atts binders instance + anew_instance atts binders instance [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); (qualid_of_ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])] @@ -1988,7 +1987,7 @@ let add_morphism_infer atts m n : Proof_global.pstate option = (None,(instance,uctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) in - add_instance (Classes.mk_instance + Classes.add_instance (Classes.mk_instance (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (ConstRef cst)); declare_projection n instance_id (ConstRef cst); None @@ -1999,7 +1998,7 @@ let add_morphism_infer atts m n : Proof_global.pstate option = let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in let hook _ _ _ = function | Globnames.ConstRef cst -> - add_instance (Classes.mk_instance + Classes.add_instance (Classes.mk_instance (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (ConstRef cst)); declare_projection n instance_id (ConstRef cst) @@ -2011,7 +2010,7 @@ let add_morphism_infer atts m n : Proof_global.pstate option = let pstate = Lemmas.start_proof ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) in Some (fst Pfedit.(by (Tacinterp.interp tac) pstate))) () -let add_morphism ~pstate atts binders m s n = +let add_morphism atts binders m s n = init_setoid (); let instance_id = add_suffix n "_Proper" in let instance_name = (CAst.make @@ Name instance_id),None in @@ -2021,12 +2020,12 @@ let add_morphism ~pstate atts binders m s n = [cHole; s; m]) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - let _, pstate = new_instance ~pstate + let _, pstate = Classes.new_instance ~program_mode:atts.program ~global:atts.global atts.polymorphic instance_name binders instance_t None ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info in - pstate + Option.get pstate (* no instance body -> always open proof *) (** Bind to "rewrite" too *) diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index cab7d0065e..e1cbc46b3b 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -81,18 +81,35 @@ val cl_rewrite_clause : val is_applied_rewrite_relation : env -> evar_map -> rel_context -> constr -> types option -val declare_relation : pstate:Proof_global.t option -> rewrite_attributes -> - ?binders:local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> - constr_expr option -> constr_expr option -> constr_expr option -> Proof_global.t option - -val add_setoid : pstate:Proof_global.t option -> - rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> constr_expr -> - Id.t -> Proof_global.t option +val declare_relation + : rewrite_attributes + -> ?binders:local_binder_expr list + -> constr_expr + -> constr_expr + -> Id.t + -> constr_expr option + -> constr_expr option + -> constr_expr option + -> unit + +val add_setoid + : rewrite_attributes + -> local_binder_expr list + -> constr_expr + -> constr_expr + -> constr_expr + -> Id.t + -> unit val add_morphism_infer : rewrite_attributes -> constr_expr -> Id.t -> Proof_global.pstate option -val add_morphism : pstate:Proof_global.t option -> - rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> Proof_global.t option +val add_morphism + : rewrite_attributes + -> local_binder_expr list + -> constr_expr + -> constr_expr + -> Id.t + -> Proof_global.pstate val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 49c547a979..bd1f925486 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -90,7 +90,6 @@ let tac2def_typ = Entry.create "tactic:tac2def_typ" let tac2def_ext = Entry.create "tactic:tac2def_ext" let tac2def_syn = Entry.create "tactic:tac2def_syn" let tac2def_mut = Entry.create "tactic:tac2def_mut" -let tac2def_run = Entry.create "tactic:tac2def_run" let tac2mode = Entry.create "vernac:ltac2_command" let ltac1_expr = Pltac.tactic_expr @@ -114,7 +113,7 @@ let pattern_of_qualid qid = GRAMMAR EXTEND Gram GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn - tac2def_mut tac2def_run; + tac2def_mut; tac2pat: [ "1" LEFTA [ qid = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> { @@ -288,9 +287,6 @@ GRAMMAR EXTEND Gram tac2def_mut: [ [ "Set"; qid = Prim.qualid; ":="; e = tac2expr -> { StrMut (qid, e) } ] ] ; - tac2def_run: - [ [ "Eval"; e = tac2expr -> { StrRun e } ] ] - ; tac2typ_knd: [ [ t = tac2type -> { CTydDef (Some t) } | "["; ".."; "]" -> { CTydOpn } @@ -878,20 +874,27 @@ PRINTED BY { pr_ltac2entry } | [ tac2def_ext(e) ] -> { e } | [ tac2def_syn(e) ] -> { e } | [ tac2def_mut(e) ] -> { e } -| [ tac2def_run(e) ] -> { e } +END + +VERNAC ARGUMENT EXTEND ltac2_expr +PRINTED BY { pr_ltac2expr } +| [ tac2expr(e) ] -> { e } END { let classify_ltac2 = function | StrSyn _ -> Vernacextend.(VtSideff [], VtNow) -| StrMut _ | StrVal _ | StrPrm _ | StrTyp _ | StrRun _ -> Vernacextend.classify_as_sideeff +| StrMut _ | StrVal _ | StrPrm _ | StrTyp _ -> Vernacextend.classify_as_sideeff } VERNAC COMMAND EXTEND VernacDeclareTactic2Definition -| #[ local = locality ] ![proof] [ "Ltac2" ltac2_entry(e) ] => { classify_ltac2 e } -> { - fun ~pstate -> Tac2entries.register_struct ?local ~pstate:(Option.map Proof_global.get_current_pstate pstate) e; pstate +| #[ local = locality ] [ "Ltac2" ltac2_entry(e) ] => { classify_ltac2 e } -> { + Tac2entries.register_struct ?local e + } +| ![proof_opt_query] [ "Ltac2" "Eval" ltac2_expr(e) ] => { Vernacextend.classify_as_sideeff } -> { + fun ~pstate -> Tac2entries.perform_eval ~pstate e } END @@ -899,15 +902,6 @@ END let _ = Pvernac.register_proof_mode "Ltac2" tac2mode -} - -VERNAC ARGUMENT EXTEND ltac2_expr -PRINTED BY { pr_ltac2expr } -| [ tac2expr(e) ] -> { e } -END - -{ - open G_ltac open Vernacextend @@ -917,9 +911,7 @@ VERNAC { tac2mode } EXTEND VernacLtac2 | ![proof] [ ltac2_expr(t) ltac_use_default(default) ] => { classify_as_proofstep } -> { (* let g = Option.default (Proof_global.get_default_goal_selector ()) g in *) - fun ~pstate -> - Option.map (fun pstate -> Tac2entries.call ~pstate ~default t) pstate - } + fun ~pstate -> Tac2entries.call ~pstate ~default t } END { diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index 254c2e5086..246fe47c4a 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -769,13 +769,12 @@ let perform_eval ~pstate e = (** Toplevel entries *) -let register_struct ?local ~pstate str = match str with +let register_struct ?local str = match str with | StrVal (mut, isrec, e) -> register_ltac ?local ~mut isrec e | StrTyp (isrec, t) -> register_type ?local isrec t | StrPrm (id, t, ml) -> register_primitive ?local id t ml | StrSyn (tok, lev, e) -> register_notation ?local tok lev e | StrMut (qid, e) -> register_redefinition ?local qid e -| StrRun e -> perform_eval ~pstate e (** Toplevel exception *) @@ -857,7 +856,7 @@ let print_ltac qid = (** Calling tactics *) let solve ~pstate default tac = - let pstate, status = Proof_global.with_current_proof begin fun etac p -> + let pstate, status = Proof_global.with_proof begin fun etac p -> let with_end_tac = if default then Some etac else None in let g = Goal_select.get_default_goal_selector () in let (p, status) = Pfedit.solve g None tac ?with_end_tac p in diff --git a/user-contrib/Ltac2/tac2entries.mli b/user-contrib/Ltac2/tac2entries.mli index e02c126e71..273cf02c9b 100644 --- a/user-contrib/Ltac2/tac2entries.mli +++ b/user-contrib/Ltac2/tac2entries.mli @@ -23,13 +23,14 @@ val register_primitive : ?local:bool -> val register_struct : ?local:bool - -> pstate:Proof_global.pstate option -> strexpr -> unit val register_notation : ?local:bool -> sexpr list -> int option -> raw_tacexpr -> unit +val perform_eval : pstate:Proof_global.pstate option -> raw_tacexpr -> unit + (** {5 Notations} *) type scope_rule = @@ -50,7 +51,7 @@ val print_ltac : Libnames.qualid -> unit (** {5 Eval loop} *) (** Evaluate a tactic expression in the current environment *) -val call : pstate:Proof_global.t -> default:bool -> raw_tacexpr -> Proof_global.t +val call : pstate:Proof_global.pstate -> default:bool -> raw_tacexpr -> Proof_global.pstate (** {5 Toplevel exceptions} *) diff --git a/user-contrib/Ltac2/tac2expr.mli b/user-contrib/Ltac2/tac2expr.mli index 2e7dfc42db..af7bc32785 100644 --- a/user-contrib/Ltac2/tac2expr.mli +++ b/user-contrib/Ltac2/tac2expr.mli @@ -168,8 +168,6 @@ type strexpr = (** Syntactic extensions *) | StrMut of qualid * raw_tacexpr (** Redefinition of mutable globals *) -| StrRun of raw_tacexpr - (** Toplevel evaluation of an expression *) (** {5 Dynamic semantics} *) diff --git a/vernac/classes.ml b/vernac/classes.ml index c783531f91..b9f57c0727 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -404,7 +404,7 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps decl ids te | None -> pstate -let do_instance ~pstate env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = +let do_instance env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = let props = match props with | Some (true, { CAst.v = CRecord fs }) -> @@ -487,17 +487,18 @@ let do_instance ~pstate env env' sigma ?hook ~tac ~global ~poly ~program_mode ct if not (Evd.has_undefined sigma) && not (Option.is_empty props) then let term = to_constr sigma (Option.get term) in (declare_instance_constant pri global imps ?hook id decl poly sigma term termtype; - pstate) + None) else if program_mode then - (declare_instance_program env sigma ~global ~poly id pri imps decl term termtype ; pstate) + (declare_instance_program env sigma ~global ~poly id pri imps decl term termtype; + None) else if Option.is_empty props then - let pstate' = + let pstate = Flags.silently (fun () -> declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps decl (List.map RelDecl.get_name ctx) term termtype) () in - Some (Proof_global.push ~ontop:pstate pstate') + Some pstate else CErrors.user_err Pp.(str "Unsolved obligations remaining.") in id, pstate @@ -529,7 +530,7 @@ let interp_instance_context ~program_mode env ctx ?(generalize=false) pl tclass let sigma = resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:true env sigma in sigma, cl, u, c', ctx', ctx, imps, args, decl -let new_instance ~pstate ?(global=false) ~program_mode +let new_instance ?(global=false) ~program_mode poly instid ctx cl props ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in @@ -545,7 +546,7 @@ let new_instance ~pstate ?(global=false) ~program_mode Namegen.next_global_ident_away i (Termops.vars_of_env env) in let env' = push_rel_context ctx env in - do_instance ~pstate env env' sigma ?hook ~tac ~global ~poly ~program_mode + do_instance env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props let declare_new_instance ?(global=false) ~program_mode poly instid ctx cl pri = diff --git a/vernac/classes.mli b/vernac/classes.mli index f80dbb9897..d441fd342c 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -32,8 +32,7 @@ val existing_instance : bool -> qualid -> Hints.hint_info_expr option -> unit (** globality, reference, optional priority and pattern information *) val new_instance : - pstate:Proof_global.t option - -> ?global:bool (** Not global by default. *) + ?global:bool (** Not global by default. *) -> program_mode:bool -> Decl_kinds.polymorphic -> name_decl @@ -44,7 +43,7 @@ val new_instance : -> ?tac:unit Proofview.tactic -> ?hook:(GlobRef.t -> unit) -> Hints.hint_info_expr - -> Id.t * Proof_global.t option (* May open a proof *) + -> Id.t * Proof_global.pstate option (* May open a proof *) val declare_new_instance : ?global:bool (** Not global by default. *) diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index f92c1f9c27..34b5e13cd8 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -60,6 +60,10 @@ let with_pstate ~pstate f = vernac_require_open_proof ~pstate (fun ~pstate -> f ~pstate:(Proof_global.get_current_pstate pstate)) +let modify_pstate ~pstate f = + vernac_require_open_proof ~pstate (fun ~pstate -> + Some (Proof_global.modify_current_pstate (fun pstate -> f ~pstate) pstate)) + let get_current_or_global_context ~pstate = match pstate with | None -> let env = Global.env () in Evd.(from_env env, env) @@ -1100,7 +1104,7 @@ let focus_command_cond = Proof.no_cond command_focus all tactics fail if there are no further goals to prove. *) let vernac_solve_existential ~pstate n com = - Proof_global.simple_with_current_proof (fun _ p -> + Proof_global.modify_proof (fun p -> let intern env sigma = Constrintern.intern_constr env sigma com in Proof.V82.instantiate_evar (Global.env ()) n intern p) pstate @@ -2441,7 +2445,8 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.t option = (* Type classes *) | VernacInstance (name, bl, t, props, info) -> - snd @@ with_def_attributes ~atts (vernac_instance ~pstate name bl t props info) + with_maybe_open_proof ~pstate (fun ~pstate:_ -> + snd @@ with_def_attributes ~atts (vernac_instance name bl t props info)) | VernacDeclareInstance (id, bl, inst, info) -> with_def_attributes ~atts vernac_declare_instance id bl inst info; pstate @@ -2459,7 +2464,7 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.t option = (* Solving *) | VernacSolveExistential (n,c) -> unsupported_attributes atts; - Some (vernac_require_open_proof ~pstate (vernac_solve_existential n c)) + modify_pstate ~pstate (vernac_solve_existential n c) (* Auxiliary file and library management *) | VernacAddLoadPath (isrec,s,alias) -> diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 12451370c8..5e6e9fdb0f 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -44,6 +44,10 @@ val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr (** Helper *) val vernac_require_open_proof : pstate:Proof_global.t option -> (pstate:Proof_global.t -> 'a) -> 'a +val with_pstate : pstate:Proof_global.t option -> (pstate:Proof_global.pstate -> 'a) -> 'a + +val modify_pstate : pstate:Proof_global.t option -> (pstate:Proof_global.pstate -> Proof_global.pstate) -> Proof_global.t option + (* Flag set when the test-suite is called. Its only effect to display verbose information for `Fail` *) val test_mode : bool ref diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index 9ab2d00fc2..6eb618ad0a 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -34,6 +34,8 @@ type t = { shallow : bool (* is the state trimmed down (libstack) *) } +let pstate st = Option.map Proof_global.get_current_pstate st.proof + let s_cache = ref None let s_proof = ref None diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index dff81ad9bb..3d21b475e9 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -25,6 +25,8 @@ type t = { shallow : bool (* is the state trimmed down (libstack) *) } +val pstate : t -> Proof_global.pstate option + val freeze_interp_state : marshallable:bool -> t val unfreeze_interp_state : t -> unit -- cgit v1.2.3 From 02fda88fc065577f3f9604477db2e03eb4d5a9b4 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Tue, 7 May 2019 14:34:06 +0200 Subject: Alternate syntax for ![]: VERNAC EXTEND Foo STATE proof eg ![proof] becomes STATE proof This commits still supports the old ![] so there is redundancy: ~~~ VERNAC EXTEND Foo STATE proof | ... VERNAC EXTEND Foo | ![proof] ... ~~~ with the ![] form being local to the rule and the STATE form applying to the whole EXTEND except for the rules with a ![]. --- coqpp/coqpp_ast.mli | 3 +- coqpp/coqpp_lex.mll | 1 + coqpp/coqpp_main.ml | 72 +++++++++++++++++-------------------- coqpp/coqpp_parse.mly | 29 ++++++++------- plugins/derive/g_derive.mlg | 4 +-- plugins/extraction/g_extraction.mlg | 4 +-- plugins/funind/g_indfun.mlg | 12 +++---- plugins/ltac/extratactics.mlg | 8 ++--- plugins/ltac/g_ltac.mlg | 6 ++-- plugins/ltac/g_obligations.mlg | 14 ++++---- vernac/vernacentries.ml | 36 +++++++++++++++++++ vernac/vernacentries.mli | 13 +++++++ 12 files changed, 125 insertions(+), 77 deletions(-) diff --git a/coqpp/coqpp_ast.mli b/coqpp/coqpp_ast.mli index 81109887ba..4ace6e78d2 100644 --- a/coqpp/coqpp_ast.mli +++ b/coqpp/coqpp_ast.mli @@ -103,7 +103,7 @@ type classification = type vernac_rule = { vernac_atts : (string * string) list option; - vernac_state: string option; + vernac_state : string option; vernac_toks : ext_token list; vernac_class : code option; vernac_depr : bool; @@ -114,6 +114,7 @@ type vernac_ext = { vernacext_name : string; vernacext_entry : code option; vernacext_class : classification; + vernacext_state : string option; vernacext_rules : vernac_rule list; } diff --git a/coqpp/coqpp_lex.mll b/coqpp/coqpp_lex.mll index 81ba8ad98c..9c6b78dc98 100644 --- a/coqpp/coqpp_lex.mll +++ b/coqpp/coqpp_lex.mll @@ -103,6 +103,7 @@ rule extend = parse | "PLUGIN" { PLUGIN } | "DEPRECATED" { DEPRECATED } | "CLASSIFIED" { CLASSIFIED } +| "STATE" { STATE } | "PRINTED" { PRINTED } | "TYPED" { TYPED } | "INTERPRETED" { INTERPRETED } diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 8444f3a58c..ad79599cf4 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -357,41 +357,35 @@ let print_atts_right fmt = function let nota = match atts with [_] -> "" | _ -> "Attributes.Notations." in fprintf fmt "(Attributes.parse %s%a atts)" nota aux atts -let print_body_wrapper fmt r = - match r.vernac_state with - | Some "proof_stack" -> - fprintf fmt "let proof = (%a) ~pstate:st.Vernacstate.proof in { st with Vernacstate.proof }" print_code r.vernac_body - - | Some "open_proof" -> - let push = "Some (Proof_global.push ~ontop:st.Vernacstate.proof pstate)" in - fprintf fmt "let pstate = (%a) in let proof = %s in { st with Vernacstate.proof }" print_code r.vernac_body push - - | Some "maybe_open_proof" -> - let push = "Proof_global.maybe_push ~ontop:st.Vernacstate.proof pstate" in - fprintf fmt "let pstate = (%a) in let proof = %s in { st with Vernacstate.proof }" print_code r.vernac_body push - - | Some "proof" -> - fprintf fmt "let proof = Vernacentries.modify_pstate ~pstate:st.Vernacstate.proof (%a) in { st with Vernacstate.proof }" print_code r.vernac_body - - | Some "proof_opt_query" -> - fprintf fmt "let () = (%a) ~pstate:(Vernacstate.pstate st) in st" print_code r.vernac_body - - | Some "proof_query" -> - fprintf fmt "let () = Vernacentries.with_pstate ~pstate:st.Vernacstate.proof (%a) in st" print_code r.vernac_body - - | None -> - fprintf fmt "let () = %a in st" print_code r.vernac_body - - | Some x -> - fatal ("unsupported state specifier: " ^ x) - -let print_body_fun fmt r = - fprintf fmt "let coqpp_body %a%a ~st = @[%a@] in " - print_binders r.vernac_toks print_atts_left r.vernac_atts print_body_wrapper r - -let print_body fmt r = +let understand_state = function + | "proof_stack" -> "VtModifyProofStack", false + | "maybe_open_proof" -> "VtMaybeOpenProof", true + | "open_proof" -> "VtOpenProof", true + | "proof" -> "VtModifyProof", false + | "proof_opt_query" -> "VtReadProofOpt", false + | "proof_query" -> "VtReadProof", false + | s -> fatal ("unsupported state specifier: " ^ s) + +let print_body_state state fmt r = + let state = match r.vernac_state with Some _ as s -> s | None -> state in + match state with + | None -> fprintf fmt "Vernacentries.VtDefault (fun () -> %a)" print_code r.vernac_body + | Some "CUSTOM" -> print_code fmt r.vernac_body + | Some state -> + let state, unit_wrap = understand_state state in + fprintf fmt "Vernacentries.%s (%s%a)" state (if unit_wrap then "fun () ->" else "") + print_code r.vernac_body + +let print_body_wrapper state fmt r = + fprintf fmt "Vernacentries.interp_functional_vernac (%a)" (print_body_state state) r + +let print_body_fun state fmt r = + fprintf fmt "let coqpp_body %a%a = @[%a@] in " + print_binders r.vernac_toks print_atts_left r.vernac_atts (print_body_wrapper state) r + +let print_body state fmt r = fprintf fmt "@[(%afun %a~atts@ ~st@ -> coqpp_body %a%a ~st)@]" - print_body_fun r print_binders r.vernac_toks + (print_body_fun state) r print_binders r.vernac_toks print_binders r.vernac_toks print_atts_right r.vernac_atts let rec print_sig fmt = function @@ -402,12 +396,12 @@ let rec print_sig fmt = function fprintf fmt "@[Vernacextend.TyNonTerminal (%a, %a)@]" print_symbol symb print_sig rem -let print_rule fmt r = +let print_rule state fmt r = fprintf fmt "Vernacextend.TyML (%b, %a, %a, %a)" - r.vernac_depr print_sig r.vernac_toks print_body r print_rule_classifier r + r.vernac_depr print_sig r.vernac_toks (print_body state) r print_rule_classifier r -let print_rules fmt rules = - print_list fmt (fun fmt r -> fprintf fmt "(%a)" print_rule r) rules +let print_rules state fmt rules = + print_list fmt (fun fmt r -> fprintf fmt "(%a)" (print_rule state) r) rules let print_classifier fmt = function | ClassifDefault -> fprintf fmt "" @@ -426,7 +420,7 @@ let print_ast fmt ext = let pr fmt () = fprintf fmt "Vernacextend.vernac_extend ~command:\"%s\" %a ?entry:%a %a" ext.vernacext_name print_classifier ext.vernacext_class - print_entry ext.vernacext_entry print_rules ext.vernacext_rules + print_entry ext.vernacext_entry (print_rules ext.vernacext_state) ext.vernacext_rules in let () = fprintf fmt "let () = @[%a@]@\n" pr () in () diff --git a/coqpp/coqpp_parse.mly b/coqpp/coqpp_parse.mly index 43ba990f6a..930a205f85 100644 --- a/coqpp/coqpp_parse.mly +++ b/coqpp/coqpp_parse.mly @@ -64,7 +64,7 @@ let parse_user_entry s sep = %token INT %token VERNAC TACTIC GRAMMAR EXTEND END DECLARE PLUGIN DEPRECATED ARGUMENT %token RAW_PRINTED GLOB_PRINTED -%token COMMAND CLASSIFIED PRINTED TYPED INTERPRETED GLOBALIZED SUBSTITUTED BY AS +%token COMMAND CLASSIFIED STATE PRINTED TYPED INTERPRETED GLOBALIZED SUBSTITUTED BY AS %token BANGBRACKET HASHBRACKET LBRACKET RBRACKET PIPE ARROW FUN COMMA EQUAL STAR %token LPAREN RPAREN COLON SEMICOLON %token GLOBAL FIRST LAST BEFORE AFTER LEVEL LEFTA RIGHTA NONA @@ -183,12 +183,13 @@ argtype: ; vernac_extend: -| VERNAC vernac_entry EXTEND IDENT vernac_classifier vernac_rules END +| VERNAC vernac_entry EXTEND IDENT vernac_classifier vernac_state vernac_rules END { VernacExt { vernacext_name = $4; vernacext_entry = $2; vernacext_class = $5; - vernacext_rules = $6; + vernacext_state = $6; + vernacext_rules = $7; } } ; @@ -203,16 +204,21 @@ vernac_classifier: | CLASSIFIED AS IDENT { ClassifName $3 } ; +vernac_state: +| { None } +| STATE IDENT { Some $2 } +; + vernac_rules: | vernac_rule { [$1] } | vernac_rule vernac_rules { $1 :: $2 } ; vernac_rule: -| PIPE vernac_attributes_opt vernac_state_opt LBRACKET ext_tokens RBRACKET rule_deprecation rule_classifier ARROW CODE +| PIPE vernac_attributes_opt rule_state LBRACKET ext_tokens RBRACKET rule_deprecation rule_classifier ARROW CODE { { vernac_atts = $2; - vernac_state= $3; + vernac_state = $3; vernac_toks = $5; vernac_depr = $7; vernac_class= $8; @@ -220,6 +226,11 @@ vernac_rule: } } ; +rule_state: +| { None } +| BANGBRACKET IDENT RBRACKET { Some $2 } +; + vernac_attributes_opt: | { None } | HASHBRACKET vernac_attributes RBRACKET { Some $2 } @@ -236,14 +247,6 @@ vernac_attribute: | qualid_or_ident { ($1, $1) } ; -vernac_state_opt: -| { None } -| BANGBRACKET vernac_state RBRACKET { Some $2 } -; - -vernac_state: -| qualid_or_ident { $1 } - rule_deprecation: | { false } | DEPRECATED { true } diff --git a/plugins/derive/g_derive.mlg b/plugins/derive/g_derive.mlg index d25b8fd01c..526989fdf3 100644 --- a/plugins/derive/g_derive.mlg +++ b/plugins/derive/g_derive.mlg @@ -22,7 +22,7 @@ let classify_derive_command _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpac } -VERNAC COMMAND EXTEND Derive CLASSIFIED BY { classify_derive_command } -| ![ open_proof ] [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> +VERNAC COMMAND EXTEND Derive CLASSIFIED BY { classify_derive_command } STATE open_proof +| [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> { Derive.(start_deriving f suchthat lemma) } END diff --git a/plugins/extraction/g_extraction.mlg b/plugins/extraction/g_extraction.mlg index 487accbc9b..9ea3fbeaf4 100644 --- a/plugins/extraction/g_extraction.mlg +++ b/plugins/extraction/g_extraction.mlg @@ -177,7 +177,7 @@ VERNAC COMMAND EXTEND ExtractionInductive CLASSIFIED AS SIDEFF END (* Show the extraction of the current proof *) -VERNAC COMMAND EXTEND ShowExtraction CLASSIFIED AS QUERY -| ![ proof_query ] [ "Show" "Extraction" ] +VERNAC COMMAND EXTEND ShowExtraction CLASSIFIED AS QUERY STATE proof_query +| [ "Show" "Extraction" ] -> { show_extraction } END diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index cc772e96f3..8c9b1e7ba4 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -176,8 +176,8 @@ let () = } (* TASSI: n'importe quoi ! *) -VERNAC COMMAND EXTEND Function -| ![ maybe_open_proof ] ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] +VERNAC COMMAND EXTEND Function STATE maybe_open_proof +| ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] => { let hard = List.exists (function | _,((_,(Some { CAst.v = CMeasureRec _ } | Some { CAst.v = CWfRec _}),_,_,_),_) -> true @@ -224,8 +224,8 @@ let warning_error names e = } -VERNAC COMMAND EXTEND NewFunctionalScheme -| ![ maybe_open_proof ] ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] +VERNAC COMMAND EXTEND NewFunctionalScheme STATE maybe_open_proof +| ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] => { Vernacextend.(VtSideff(List.map pi1 fas), VtLater) } -> { begin @@ -263,7 +263,7 @@ VERNAC COMMAND EXTEND NewFunctionalCase END (***** debug only ***) -VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY -| ![ maybe_open_proof ] ["Generate" "graph" "for" reference(c)] -> +VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY STATE maybe_open_proof +| ["Generate" "graph" "for" reference(c)] -> { make_graph (Smartlocate.global_with_alias c) } END diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 4a2fb425ac..0ded60d9c7 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -931,8 +931,8 @@ END (* spiwack: I put it in extratactics because it is somewhat tied with the semantics of the LCF-style tactics, hence with the classic tactic mode. *) -VERNAC COMMAND EXTEND GrabEvars -| ![ proof ] [ "Grab" "Existential" "Variables" ] +VERNAC COMMAND EXTEND GrabEvars STATE proof +| [ "Grab" "Existential" "Variables" ] => { classify_as_proofstep } -> { fun ~pstate -> Proof_global.modify_proof (fun p -> Proof.V82.grab_evars p) pstate } END @@ -963,8 +963,8 @@ TACTIC EXTEND unshelve END (* Command to add every unshelved variables to the focus *) -VERNAC COMMAND EXTEND Unshelve -| ![ proof ] [ "Unshelve" ] +VERNAC COMMAND EXTEND Unshelve STATE proof +| [ "Unshelve" ] => { classify_as_proofstep } -> { fun ~pstate -> Proof_global.modify_proof (fun p -> Proof.unshelve p) pstate } END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 9bf5bd1bda..960e5b76f8 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -434,13 +434,13 @@ let is_explicit_terminator = function TacSolve _ -> true | _ -> false } -VERNAC { tactic_mode } EXTEND VernacSolve -| ![ proof ] [ ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => +VERNAC { tactic_mode } EXTEND VernacSolve STATE proof +| [ ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => { classify_as_proofstep } -> { let g = Option.default (Goal_select.get_default_goal_selector ()) g in vernac_solve g n t def } -| ![ proof ] [ "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => +| [ "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => { let anon_abstracting_tac = is_anonymous_abstract t in let solving_tac = is_explicit_terminator t in diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index c01b97c14d..58c8dabd79 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -87,18 +87,18 @@ let classify_obbl _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[]), V } -VERNAC COMMAND EXTEND Obligations CLASSIFIED BY { classify_obbl } -| ![ open_proof ] [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> +VERNAC COMMAND EXTEND Obligations CLASSIFIED BY { classify_obbl } STATE open_proof +| [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> { obligation (num, Some name, Some t) tac } -| ![ open_proof ] [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> +| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> { obligation (num, Some name, None) tac } -| ![ open_proof ] [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> +| [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> { obligation (num, None, Some t) tac } -| ![ open_proof ] [ "Obligation" integer(num) withtac(tac) ] -> +| [ "Obligation" integer(num) withtac(tac) ] -> { obligation (num, None, None) tac } -| ![ open_proof ] [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> +| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> { next_obligation (Some name) tac } -| ![ open_proof ] [ "Next" "Obligation" withtac(tac) ] -> { next_obligation None tac } +| [ "Next" "Obligation" withtac(tac) ] -> { next_obligation None tac } END VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 34b5e13cd8..e4667e376c 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -2711,3 +2711,39 @@ let interp ?(verbosely=true) ?proof ~st cmd = let exn = locate_if_not_already ?loc:cmd.CAst.loc exn in Vernacstate.invalidate_cache (); iraise exn + +(* mlg helpers *) + +type functional_vernac = + | VtDefault of (unit -> unit) + | VtModifyProofStack of (pstate:Proof_global.t option -> Proof_global.t option) + | VtMaybeOpenProof of (unit -> Proof_global.pstate option) + | VtOpenProof of (unit -> Proof_global.pstate) + | VtModifyProof of (pstate:Proof_global.pstate -> Proof_global.pstate) + | VtReadProofOpt of (pstate:Proof_global.pstate option -> unit) + | VtReadProof of (pstate:Proof_global.pstate -> unit) + +let interp_functional_vernac c ~st = + let open Proof_global in + let open Vernacstate in + match c with + | VtDefault f -> f (); st + | VtModifyProofStack f -> + let proof = f ~pstate:st.proof in { st with proof } + | VtMaybeOpenProof f -> + let pstate = f () in + let proof = maybe_push ~ontop:st.proof pstate in + { st with proof } + | VtOpenProof f -> + let pstate = f () in + let proof = Some (push ~ontop:st.proof pstate) in + { st with proof } + | VtModifyProof f -> + let proof = modify_pstate f ~pstate:st.proof in + { st with proof } + | VtReadProofOpt f -> + f ~pstate:(Option.map get_current_pstate st.proof); + st + | VtReadProof f -> + with_pstate ~pstate:st.proof f; + st diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 5e6e9fdb0f..9756c1e0bb 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -51,3 +51,16 @@ val modify_pstate : pstate:Proof_global.t option -> (pstate:Proof_global.pstate (* Flag set when the test-suite is called. Its only effect to display verbose information for `Fail` *) val test_mode : bool ref + +(** For mlg *) + +type functional_vernac = + | VtDefault of (unit -> unit) + | VtModifyProofStack of (pstate:Proof_global.t option -> Proof_global.t option) + | VtMaybeOpenProof of (unit -> Proof_global.pstate option) + | VtOpenProof of (unit -> Proof_global.pstate) + | VtModifyProof of (pstate:Proof_global.pstate -> Proof_global.pstate) + | VtReadProofOpt of (pstate:Proof_global.pstate option -> unit) + | VtReadProof of (pstate:Proof_global.pstate -> unit) + +val interp_functional_vernac : functional_vernac -> st:Vernacstate.t -> Vernacstate.t -- cgit v1.2.3 From 445dee163b7a2c9d4cc24da739d743d80fcec529 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Mon, 20 May 2019 16:49:03 +0200 Subject: Funind: use maybe_open_proof a bit less --- plugins/funind/g_indfun.mlg | 14 +++++++------- plugins/funind/indfun.ml | 4 ++-- plugins/funind/indfun.mli | 2 +- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 8c9b1e7ba4..bdd30aae0a 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -224,33 +224,33 @@ let warning_error names e = } -VERNAC COMMAND EXTEND NewFunctionalScheme STATE maybe_open_proof +VERNAC COMMAND EXTEND NewFunctionalScheme | ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] => { Vernacextend.(VtSideff(List.map pi1 fas), VtLater) } -> { begin try - Functional_principles_types.build_scheme fas; None + Functional_principles_types.build_scheme fas with | Functional_principles_types.No_graph_found -> begin match fas with | (_,fun_name,_)::_ -> begin - let pstate = make_graph (Smartlocate.global_with_alias fun_name) in - try Functional_principles_types.build_scheme fas; pstate + make_graph (Smartlocate.global_with_alias fun_name); + try Functional_principles_types.build_scheme fas with | Functional_principles_types.No_graph_found -> CErrors.user_err Pp.(str "Cannot generate induction principle(s)") | e when CErrors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in - warning_error names e; pstate + warning_error names e end | _ -> assert false (* we can only have non empty list *) end | e when CErrors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in - warning_error names e; None + warning_error names e end } END @@ -263,7 +263,7 @@ VERNAC COMMAND EXTEND NewFunctionalCase END (***** debug only ***) -VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY STATE maybe_open_proof +VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY | ["Generate" "graph" "for" reference(c)] -> { make_graph (Smartlocate.global_with_alias c) } END diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 6ea2eb579f..16df34e214 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -903,10 +903,10 @@ let make_graph (f_ref : GlobRef.t) = in let mp = Constant.modpath c in let pstate = do_generate_principle [c,Univ.Instance.empty] error_error false false expr_list in + assert (Option.is_empty pstate); (* We register the infos *) List.iter (fun ((({CAst.v=id},_),_,_,_,_),_) -> add_Function false (Constant.make2 mp (Label.of_id id))) - expr_list; - pstate) + expr_list) let do_generate_principle = do_generate_principle [] warning_error true diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index c803484617..cd39266378 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -17,4 +17,4 @@ val functional_induction : Ltac_plugin.Tacexpr.or_and_intro_pattern option -> Goal.goal Evd.sigma -> Goal.goal list Evd.sigma -val make_graph : GlobRef.t -> Proof_global.pstate option +val make_graph : GlobRef.t -> unit -- cgit v1.2.3 From 788b47d9dd70dc9f8057d4a9353ed24f091ea917 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Mon, 20 May 2019 17:02:55 +0200 Subject: Vernacextend only returns a proof_global.t option, not a vernacstate --- coqpp/coqpp_main.ml | 2 +- dev/top_printers.ml | 4 ++-- vernac/vernacentries.ml | 33 +++++++++++++-------------------- vernac/vernacentries.mli | 5 ++++- vernac/vernacextend.ml | 12 ++++++------ vernac/vernacextend.mli | 6 +++--- 6 files changed, 29 insertions(+), 33 deletions(-) diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index ad79599cf4..b118d9ec00 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -384,7 +384,7 @@ let print_body_fun state fmt r = print_binders r.vernac_toks print_atts_left r.vernac_atts (print_body_wrapper state) r let print_body state fmt r = - fprintf fmt "@[(%afun %a~atts@ ~st@ -> coqpp_body %a%a ~st)@]" + fprintf fmt "@[(%afun %a~atts@ ~pstate@ -> coqpp_body %a%a ~pstate)@]" (print_body_fun state) r print_binders r.vernac_toks print_binders r.vernac_toks print_atts_right r.vernac_atts diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 2859b56cbe..db444a9b78 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -532,7 +532,7 @@ let _ = let open Vernacextend in let ty_constr = Extend.TUentry (get_arg_tag Stdarg.wit_constr) in let cmd_sig = TyTerminal("PrintConstr", TyNonTerminal(ty_constr, TyNil)) in - let cmd_fn c ~atts ~st = in_current_context econstr_display c; st in + let cmd_fn c ~atts ~pstate = in_current_context econstr_display c; pstate in let cmd_class _ = VtQuery,VtNow in let cmd : ty_ml = TyML (false, cmd_sig, cmd_fn, Some cmd_class) in vernac_extend ~command:"PrintConstr" [cmd] @@ -541,7 +541,7 @@ let _ = let open Vernacextend in let ty_constr = Extend.TUentry (get_arg_tag Stdarg.wit_constr) in let cmd_sig = TyTerminal("PrintPureConstr", TyNonTerminal(ty_constr, TyNil)) in - let cmd_fn c ~atts ~st = in_current_context print_pure_econstr c; st in + let cmd_fn c ~atts ~pstate = in_current_context print_pure_econstr c; pstate in let cmd_class _ = VtQuery,VtNow in let cmd : ty_ml = TyML (false, cmd_sig, cmd_fn, Some cmd_class) in vernac_extend ~command:"PrintPureConstr" [cmd] diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index e4667e376c..49ce27ee30 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -2629,9 +2629,7 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.t option = (* Extensions *) | VernacExtend (opn,args) -> - (* XXX: Here we are returning the state! :) *) - let st : Vernacstate.t = Vernacextend.call ~atts opn args ~st in - st.Vernacstate.proof + Vernacextend.call ~atts opn args ~pstate (* XXX: This won't properly set the proof mode, as of today, it is controlled by the STM. Thus, we would need access information from @@ -2723,27 +2721,22 @@ type functional_vernac = | VtReadProofOpt of (pstate:Proof_global.pstate option -> unit) | VtReadProof of (pstate:Proof_global.pstate -> unit) -let interp_functional_vernac c ~st = +let interp_functional_vernac c ~pstate = let open Proof_global in - let open Vernacstate in match c with - | VtDefault f -> f (); st - | VtModifyProofStack f -> - let proof = f ~pstate:st.proof in { st with proof } + | VtDefault f -> f (); pstate + | VtModifyProofStack f -> f ~pstate | VtMaybeOpenProof f -> - let pstate = f () in - let proof = maybe_push ~ontop:st.proof pstate in - { st with proof } + let proof = f () in + let pstate = maybe_push ~ontop:pstate proof in + pstate | VtOpenProof f -> - let pstate = f () in - let proof = Some (push ~ontop:st.proof pstate) in - { st with proof } + Some (push ~ontop:pstate (f ())) | VtModifyProof f -> - let proof = modify_pstate f ~pstate:st.proof in - { st with proof } + modify_pstate f ~pstate | VtReadProofOpt f -> - f ~pstate:(Option.map get_current_pstate st.proof); - st + f ~pstate:(Option.map get_current_pstate pstate); + pstate | VtReadProof f -> - with_pstate ~pstate:st.proof f; - st + with_pstate ~pstate f; + pstate diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 9756c1e0bb..55763d9e51 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -63,4 +63,7 @@ type functional_vernac = | VtReadProofOpt of (pstate:Proof_global.pstate option -> unit) | VtReadProof of (pstate:Proof_global.pstate -> unit) -val interp_functional_vernac : functional_vernac -> st:Vernacstate.t -> Vernacstate.t +val interp_functional_vernac + : functional_vernac + -> pstate:Proof_global.t option + -> Proof_global.t option diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 730f5fd6da..008d3d854f 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -53,14 +53,14 @@ type vernac_when = | VtLater type vernac_classification = vernac_type * vernac_when -type 'a vernac_command = 'a -> atts:Attributes.vernac_flags -> st:Vernacstate.t -> Vernacstate.t +type vernac_command = atts:Attributes.vernac_flags -> pstate:Proof_global.t option -> Proof_global.t option type plugin_args = Genarg.raw_generic_argument list (* Table of vernac entries *) let vernac_tab = (Hashtbl.create 211 : - (Vernacexpr.extend_name, bool * plugin_args vernac_command) Hashtbl.t) + (Vernacexpr.extend_name, bool * (plugin_args -> vernac_command)) Hashtbl.t) let vinterp_add depr s f = try @@ -83,7 +83,7 @@ let warn_deprecated_command = (* Interpretation of a vernac command *) -let call opn converted_args ~atts ~st = +let call opn converted_args ~atts ~pstate = let phase = ref "Looking up command" in try let depr, callback = vinterp_map opn in @@ -99,7 +99,7 @@ let call opn converted_args ~atts ~st = phase := "Checking arguments"; let hunk = callback converted_args in phase := "Executing command"; - hunk ~atts ~st + hunk ~atts ~pstate with | reraise -> let reraise = CErrors.push reraise in @@ -125,7 +125,7 @@ let classify_as_sideeff = VtSideff [], VtLater let classify_as_proofstep = VtProofStep { parallel = `No; proof_block_detection = None}, VtLater type (_, _) ty_sig = -| TyNil : (atts:Attributes.vernac_flags -> st:Vernacstate.t -> Vernacstate.t, vernac_classification) ty_sig +| TyNil : (vernac_command, vernac_classification) ty_sig | TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig | TyNonTerminal : ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> ('a -> 'r, 'a -> 's) ty_sig @@ -151,7 +151,7 @@ let rec untype_classifier : type r s. (r, s) ty_sig -> s -> classifier = functio end (** Stupid GADTs forces us to duplicate the definition just for typing *) -let rec untype_command : type r s. (r, s) ty_sig -> r -> plugin_args vernac_command = function +let rec untype_command : type r s. (r, s) ty_sig -> r -> plugin_args -> vernac_command = function | TyNil -> fun f args -> begin match args with | [] -> f diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index b37e527f47..6189830929 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -71,18 +71,18 @@ type vernac_classification = vernac_type * vernac_when (** Interpretation of extended vernac phrases. *) -type 'a vernac_command = 'a -> atts:Attributes.vernac_flags -> st:Vernacstate.t -> Vernacstate.t +type vernac_command = atts:Attributes.vernac_flags -> pstate:Proof_global.t option -> Proof_global.t option type plugin_args = Genarg.raw_generic_argument list -val call : Vernacexpr.extend_name -> plugin_args -> atts:Attributes.vernac_flags -> st:Vernacstate.t -> Vernacstate.t +val call : Vernacexpr.extend_name -> plugin_args -> vernac_command (** {5 VERNAC EXTEND} *) type classifier = Genarg.raw_generic_argument list -> vernac_classification type (_, _) ty_sig = -| TyNil : (atts:Attributes.vernac_flags -> st:Vernacstate.t -> Vernacstate.t, vernac_classification) ty_sig +| TyNil : (vernac_command, vernac_classification) ty_sig | TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig | TyNonTerminal : ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> -- cgit v1.2.3 From 1ea1e218eed9792685bd7467b63a17fb5ebdbb7e Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Mon, 20 May 2019 17:08:38 +0200 Subject: Rename Proof_global.{t -> stack} --- proofs/proof_global.ml | 4 ++-- proofs/proof_global.mli | 24 ++++++++++++------------ stm/stm.ml | 2 +- vernac/lemmas.mli | 6 +++--- vernac/vernacentries.ml | 6 +++--- vernac/vernacentries.mli | 12 ++++++------ vernac/vernacextend.ml | 2 +- vernac/vernacextend.mli | 2 +- vernac/vernacstate.ml | 2 +- vernac/vernacstate.mli | 14 +++++++------- 10 files changed, 37 insertions(+), 37 deletions(-) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 8d7960829b..e26577e8bd 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -56,7 +56,7 @@ type pstate = { (* The head of [t] is the actual current proof, the other ones are to be resumed when the current proof is closed or aborted. *) -type t = pstate * pstate list +type stack = pstate * pstate list let pstate_map f (pf, pfl) = (f pf, List.map f pfl) @@ -77,7 +77,7 @@ let maybe_push ~ontop = function (*** Proof Global manipulation ***) -let get_all_proof_names (pf : t) = +let get_all_proof_names (pf : stack) = let (pn, pns) = pstate_map Proof.(function pf -> (data pf.proof).name) pf in pn :: pns diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 6984fff63a..aa538bd581 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -13,16 +13,16 @@ environment. *) type pstate -type t +type stack -val get_current_pstate : t -> pstate +val get_current_pstate : stack -> pstate val get_current_proof_name : pstate -> Names.Id.t val get_current_persistence : pstate -> Decl_kinds.goal_kind -val get_all_proof_names : t -> Names.Id.t list +val get_all_proof_names : stack -> Names.Id.t list -val discard : Names.lident -> t -> t option -val discard_current : t -> t option +val discard : Names.lident -> stack -> stack option +val discard_current : stack -> stack option val give_me_the_proof : pstate -> Proof.t val compact_the_proof : pstate -> pstate @@ -56,9 +56,9 @@ type closed_proof = proof_object * proof_terminator val make_terminator : (proof_ending -> unit) -> proof_terminator val apply_terminator : proof_terminator -> proof_ending -> unit -val push : ontop:t option -> pstate -> t +val push : ontop:stack option -> pstate -> stack -val maybe_push : ontop:t option -> pstate option -> t option +val maybe_push : ontop:stack option -> pstate option -> stack option (** [start_proof ~ontop id str pl goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and @@ -111,15 +111,15 @@ val get_open_goals : pstate -> int no current proof. The return boolean is set to [false] if an unsafe tactic has been used. *) val with_current_proof : - (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> t -> t * 'a + (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> stack -> stack * 'a val simple_with_current_proof : - (unit Proofview.tactic -> Proof.t -> Proof.t) -> t -> t + (unit Proofview.tactic -> Proof.t -> Proof.t) -> stack -> stack val with_proof : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> pstate -> pstate * 'a val modify_proof : (Proof.t -> Proof.t) -> pstate -> pstate -val with_current_pstate : (pstate -> pstate * 'a) -> t -> t * 'a -val modify_current_pstate : (pstate -> pstate) -> t -> t +val with_current_pstate : (pstate -> pstate * 'a) -> stack -> stack * 'a +val modify_current_pstate : (pstate -> pstate) -> stack -> stack (** Sets the tactic to be used when a tactic line is closed with [...] *) val set_endline_tactic : Genarg.glob_generic_argument -> pstate -> pstate @@ -135,4 +135,4 @@ val get_used_variables : pstate -> Constr.named_context option (** Get the universe declaration associated to the current proof. *) val get_universe_decl : pstate -> UState.universe_decl -val copy_terminators : src:t -> tgt:t -> t +val copy_terminators : src:stack -> tgt:stack -> stack diff --git a/stm/stm.ml b/stm/stm.ml index 64f9e4aacf..0efea0b8e0 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -881,7 +881,7 @@ end = struct (* {{{ *) let invalidate_cur_state () = cur_id := Stateid.dummy type proof_part = - Proof_global.t option * + Proof_global.stack option * int * (* Evarutil.meta_counter_summary_tag *) int * (* Evd.evar_counter_summary_tag *) Obligations.program_info Names.Id.Map.t (* Obligations.program_tcc_summary_tag *) diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index ad6eb024aa..e613b79c7b 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -61,7 +61,7 @@ val standard_proof_terminator : ?hook:declaration_hook -> Proof_global.lemma_possible_guards -> Proof_global.proof_terminator -val fresh_name_for_anonymous_theorem : pstate:Proof_global.t option -> Id.t +val fresh_name_for_anonymous_theorem : pstate:Proof_global.stack option -> Id.t (* Prepare global named context for proof session: remove proofs of opaque section definitions and remove vm-compiled code *) @@ -77,10 +77,10 @@ val save_proof_admitted val save_proof_proved : ?proof:Proof_global.closed_proof - -> ?ontop:Proof_global.t + -> ?ontop:Proof_global.stack -> opaque:Proof_global.opacity_flag -> idopt:Names.lident option - -> Proof_global.t option + -> Proof_global.stack option val save_pstate_proved : pstate:Proof_global.pstate diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 49ce27ee30..8d15191ebe 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -1937,7 +1937,7 @@ let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = let sigma, env = get_current_or_global_context ~pstate in print_about env sigma ref_or_by_not udecl -let vernac_print ~(pstate : Proof_global.t option) ~atts = +let vernac_print ~(pstate : Proof_global.stack option) ~atts = let pstate = Option.map Proof_global.get_current_pstate pstate in let sigma, env = get_current_or_global_context ~pstate in function @@ -2299,7 +2299,7 @@ exception End_of_input * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) -let rec interp_expr ?proof ~atts ~st c : Proof_global.t option = +let rec interp_expr ?proof ~atts ~st c : Proof_global.stack option = let pstate = st.Vernacstate.proof in vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); match c with @@ -2714,7 +2714,7 @@ let interp ?(verbosely=true) ?proof ~st cmd = type functional_vernac = | VtDefault of (unit -> unit) - | VtModifyProofStack of (pstate:Proof_global.t option -> Proof_global.t option) + | VtModifyProofStack of (pstate:Proof_global.stack option -> Proof_global.stack option) | VtMaybeOpenProof of (unit -> Proof_global.pstate option) | VtOpenProof of (unit -> Proof_global.pstate) | VtModifyProof of (pstate:Proof_global.pstate -> Proof_global.pstate) diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 55763d9e51..552be6e407 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -42,11 +42,11 @@ val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr Evd.evar_map * Redexpr.red_expr) Hook.t (** Helper *) -val vernac_require_open_proof : pstate:Proof_global.t option -> (pstate:Proof_global.t -> 'a) -> 'a +val vernac_require_open_proof : pstate:Proof_global.stack option -> (pstate:Proof_global.stack -> 'a) -> 'a -val with_pstate : pstate:Proof_global.t option -> (pstate:Proof_global.pstate -> 'a) -> 'a +val with_pstate : pstate:Proof_global.stack option -> (pstate:Proof_global.pstate -> 'a) -> 'a -val modify_pstate : pstate:Proof_global.t option -> (pstate:Proof_global.pstate -> Proof_global.pstate) -> Proof_global.t option +val modify_pstate : pstate:Proof_global.stack option -> (pstate:Proof_global.pstate -> Proof_global.pstate) -> Proof_global.stack option (* Flag set when the test-suite is called. Its only effect to display verbose information for `Fail` *) @@ -56,7 +56,7 @@ val test_mode : bool ref type functional_vernac = | VtDefault of (unit -> unit) - | VtModifyProofStack of (pstate:Proof_global.t option -> Proof_global.t option) + | VtModifyProofStack of (pstate:Proof_global.stack option -> Proof_global.stack option) | VtMaybeOpenProof of (unit -> Proof_global.pstate option) | VtOpenProof of (unit -> Proof_global.pstate) | VtModifyProof of (pstate:Proof_global.pstate -> Proof_global.pstate) @@ -65,5 +65,5 @@ type functional_vernac = val interp_functional_vernac : functional_vernac - -> pstate:Proof_global.t option - -> Proof_global.t option + -> pstate:Proof_global.stack option + -> Proof_global.stack option diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 008d3d854f..644413cbb9 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -53,7 +53,7 @@ type vernac_when = | VtLater type vernac_classification = vernac_type * vernac_when -type vernac_command = atts:Attributes.vernac_flags -> pstate:Proof_global.t option -> Proof_global.t option +type vernac_command = atts:Attributes.vernac_flags -> pstate:Proof_global.stack option -> Proof_global.stack option type plugin_args = Genarg.raw_generic_argument list diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 6189830929..46cee30a1e 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -71,7 +71,7 @@ type vernac_classification = vernac_type * vernac_when (** Interpretation of extended vernac phrases. *) -type vernac_command = atts:Attributes.vernac_flags -> pstate:Proof_global.t option -> Proof_global.t option +type vernac_command = atts:Attributes.vernac_flags -> pstate:Proof_global.stack option -> Proof_global.stack option type plugin_args = Genarg.raw_generic_argument list diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index 6eb618ad0a..0fbde1ade5 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -30,7 +30,7 @@ end type t = { parsing : Parser.state; system : States.state; (* summary + libstack *) - proof : Proof_global.t option; (* proof state *) + proof : Proof_global.stack option; (* proof state *) shallow : bool (* is the state trimmed down (libstack) *) } diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index 3d21b475e9..f52cd6a829 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -21,7 +21,7 @@ end type t = { parsing : Parser.state; system : States.state; (* summary + libstack *) - proof : Proof_global.t option; (* proof state *) + proof : Proof_global.stack option; (* proof state *) shallow : bool (* is the state trimmed down (libstack) *) } @@ -41,11 +41,11 @@ module Proof_global : sig open Proof_global (* Low-level stuff *) - val get : unit -> t option - val set : t option -> unit + val get : unit -> stack option + val set : stack option -> unit - val freeze : marshallable:bool -> t option - val unfreeze : t -> unit + val freeze : marshallable:bool -> stack option + val unfreeze : stack -> unit exception NoCurrentProof @@ -63,7 +63,7 @@ module Proof_global : sig val with_current_proof : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a - val install_state : t -> unit + val install_state : stack -> unit val return_proof : ?allow_partial:bool -> unit -> closed_proof_output @@ -81,7 +81,7 @@ module Proof_global : sig val get_all_proof_names : unit -> Names.Id.t list - val copy_terminators : src:t option -> tgt:t option -> t option + val copy_terminators : src:stack option -> tgt:stack option -> stack option end [@@ocaml.deprecated "This module is internal and should not be used, instead, thread the proof state"] -- cgit v1.2.3 From 99154fcb97653c606d2e62e0a0521c4afddff44c Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Mon, 20 May 2019 17:11:00 +0200 Subject: Rename Proof_global.{pstate -> t} --- plugins/derive/derive.mli | 2 +- plugins/extraction/extract_env.mli | 2 +- plugins/funind/indfun.ml | 2 +- plugins/funind/indfun.mli | 2 +- plugins/funind/recdef.ml | 2 +- plugins/funind/recdef.mli | 2 +- plugins/ltac/rewrite.ml | 2 +- plugins/ltac/rewrite.mli | 4 +-- proofs/pfedit.mli | 8 +++--- proofs/proof_global.ml | 4 +-- proofs/proof_global.mli | 52 +++++++++++++++++++------------------- tactics/hints.mli | 2 +- user-contrib/Ltac2/tac2entries.mli | 4 +-- vernac/classes.mli | 2 +- vernac/comFixpoint.mli | 8 +++--- vernac/lemmas.mli | 10 ++++---- vernac/obligations.mli | 4 +-- vernac/search.mli | 12 ++++----- vernac/vernacentries.ml | 12 ++++----- vernac/vernacentries.mli | 14 +++++----- vernac/vernacstate.mli | 2 +- 21 files changed, 76 insertions(+), 76 deletions(-) diff --git a/plugins/derive/derive.mli b/plugins/derive/derive.mli index 6e4bffa0b6..6bb923118e 100644 --- a/plugins/derive/derive.mli +++ b/plugins/derive/derive.mli @@ -12,4 +12,4 @@ (which can contain references to [f]) in the context extended by [f:=?x]. When the proof ends, [f] is defined as the value of [?x] and [lemma] as the proof. *) -val start_deriving : Names.Id.t -> Constrexpr.constr_expr -> Names.Id.t -> Proof_global.pstate +val start_deriving : Names.Id.t -> Constrexpr.constr_expr -> Names.Id.t -> Proof_global.t diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index efd5b5575f..7d04fee7c1 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -40,4 +40,4 @@ val structure_for_compute : (* Show the extraction of the current ongoing proof *) -val show_extraction : pstate:Proof_global.pstate -> unit +val show_extraction : pstate:Proof_global.t -> unit diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 16df34e214..7c6669d0fc 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -634,7 +634,7 @@ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacex let do_generate_principle pconstants on_error register_built interactive_proof - (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) : Proof_global.pstate option = + (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) : Proof_global.t option = List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl; let pstate, _is_struct = match fixpoint_exprl with diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index cd39266378..47d37b29a5 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -8,7 +8,7 @@ val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit val do_generate_principle : bool -> (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> - Proof_global.pstate option + Proof_global.t option val functional_induction : bool -> diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index b4d0f092d8..5a682e7231 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1495,7 +1495,7 @@ let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq - generate_induction_principle using_lemmas : Proof_global.pstate option = + generate_induction_principle using_lemmas : Proof_global.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 84d7a399e1..90f9c449b1 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -14,4 +14,4 @@ bool -> int -> Constrexpr.constr_expr -> (pconstant -> Indfun_common.tcc_lemma_value ref -> pconstant -> - pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> Constrexpr.constr_expr list -> Proof_global.pstate option + pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> Constrexpr.constr_expr list -> Proof_global.t option diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 5d57a2f27f..26d477fee0 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1973,7 +1973,7 @@ let warn_add_morphism_deprecated = CWarnings.create ~name:"add-morphism" ~category:"deprecated" (fun () -> Pp.(str "Add Morphism f : id is deprecated, please use Add Morphism f with signature (...) as id")) -let add_morphism_infer atts m n : Proof_global.pstate option = +let add_morphism_infer atts m n : Proof_global.t option = warn_add_morphism_deprecated ?loc:m.CAst.loc (); init_setoid (); let instance_id = add_suffix n "_Proper" in diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index e1cbc46b3b..5aabb946d5 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -101,7 +101,7 @@ val add_setoid -> Id.t -> unit -val add_morphism_infer : rewrite_attributes -> constr_expr -> Id.t -> Proof_global.pstate option +val add_morphism_infer : rewrite_attributes -> constr_expr -> Id.t -> Proof_global.t option val add_morphism : rewrite_attributes @@ -109,7 +109,7 @@ val add_morphism -> constr_expr -> constr_expr -> Id.t - -> Proof_global.pstate + -> Proof_global.t val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index ec52d2d5cf..77d701b41f 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -23,17 +23,17 @@ exception NoSuchGoal the current focused proof or raises a [UserError] if there is no focused proof or if there is no more subgoals *) -val get_goal_context : Proof_global.pstate -> int -> Evd.evar_map * env +val get_goal_context : Proof_global.t -> int -> Evd.evar_map * env (** [get_current_goal_context ()] works as [get_goal_context 1] *) -val get_current_goal_context : Proof_global.pstate -> Evd.evar_map * env +val get_current_goal_context : Proof_global.t -> Evd.evar_map * env (** [get_current_context ()] returns the context of the current focused goal. If there is no focused goal but there is a proof in progress, it returns the corresponding evar_map. If there is no pending proof then it returns the current global environment and empty evar_map. *) -val get_current_context : Proof_global.pstate -> Evd.evar_map * env +val get_current_context : Proof_global.t -> Evd.evar_map * env (** {6 ... } *) @@ -49,7 +49,7 @@ val solve : ?with_end_tac:unit Proofview.tactic -> focused proof. Returns [false] if an unsafe tactic has been used. *) -val by : unit Proofview.tactic -> Proof_global.pstate -> Proof_global.pstate * bool +val by : unit Proofview.tactic -> Proof_global.t -> Proof_global.t * bool (** Option telling if unification heuristics should be used. *) val use_unification_heuristics : unit -> bool diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index e26577e8bd..b642e8eea7 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -45,7 +45,7 @@ type proof_ending = type proof_terminator = proof_ending -> unit type closed_proof = proof_object * proof_terminator -type pstate = { +type t = { terminator : proof_terminator CEphemeron.key; endline_tactic : Genarg.glob_generic_argument option; section_vars : Constr.named_context option; @@ -56,7 +56,7 @@ type pstate = { (* The head of [t] is the actual current proof, the other ones are to be resumed when the current proof is closed or aborted. *) -type stack = pstate * pstate list +type stack = t * t list let pstate_map f (pf, pfl) = (f pf, List.map f pfl) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index aa538bd581..aff48b9636 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -12,20 +12,20 @@ toplevel. In particular it defines the global proof environment. *) -type pstate +type t type stack -val get_current_pstate : stack -> pstate +val get_current_pstate : stack -> t -val get_current_proof_name : pstate -> Names.Id.t -val get_current_persistence : pstate -> Decl_kinds.goal_kind +val get_current_proof_name : t -> Names.Id.t +val get_current_persistence : t -> Decl_kinds.goal_kind val get_all_proof_names : stack -> Names.Id.t list val discard : Names.lident -> stack -> stack option val discard_current : stack -> stack option -val give_me_the_proof : pstate -> Proof.t -val compact_the_proof : pstate -> pstate +val give_me_the_proof : t -> Proof.t +val compact_the_proof : t -> t (** When a proof is closed, it is reified into a [proof_object], where [id] is the name of the proof, [entries] the list of the proof terms @@ -56,9 +56,9 @@ type closed_proof = proof_object * proof_terminator val make_terminator : (proof_ending -> unit) -> proof_terminator val apply_terminator : proof_terminator -> proof_ending -> unit -val push : ontop:stack option -> pstate -> stack +val push : ontop:stack option -> t -> stack -val maybe_push : ontop:stack option -> pstate option -> stack option +val maybe_push : ontop:stack option -> t option -> stack option (** [start_proof ~ontop id str pl goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and @@ -71,23 +71,23 @@ val maybe_push : ontop:stack option -> pstate option -> stack option val start_proof : Evd.evar_map -> Names.Id.t -> ?pl:UState.universe_decl -> Decl_kinds.goal_kind -> (Environ.env * EConstr.types) list -> - proof_terminator -> pstate + proof_terminator -> t (** Like [start_proof] except that there may be dependencies between initial goals. *) val start_dependent_proof : Names.Id.t -> ?pl:UState.universe_decl -> Decl_kinds.goal_kind -> - Proofview.telescope -> proof_terminator -> pstate + Proofview.telescope -> proof_terminator -> t (** Update the proofs global environment after a side-effecting command (e.g. a sublemma definition) has been run inside it. Assumes there_are_pending_proofs. *) -val update_global_env : pstate -> pstate +val update_global_env : t -> t (* Takes a function to add to the exceptions data relative to the state in which the proof was built *) val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> - pstate -> closed_proof + t -> closed_proof (* Intermediate step necessary to delegate the future. * Both access the current proof state. The former is supposed to be @@ -97,15 +97,15 @@ type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * USt (* If allow_partial is set (default no) then an incomplete proof * is allowed (no error), and a warn is given if the proof is complete. *) -val return_proof : ?allow_partial:bool -> pstate -> closed_proof_output -val close_future_proof : opaque:opacity_flag -> feedback_id:Stateid.t -> pstate -> +val return_proof : ?allow_partial:bool -> t -> closed_proof_output +val close_future_proof : opaque:opacity_flag -> feedback_id:Stateid.t -> t -> closed_proof_output Future.computation -> closed_proof (** Gets the current terminator without checking that the proof has been completed. Useful for the likes of [Admitted]. *) -val get_terminator : pstate -> proof_terminator -val set_terminator : proof_terminator -> pstate -> pstate -val get_open_goals : pstate -> int +val get_terminator : t -> proof_terminator +val set_terminator : proof_terminator -> t -> t +val get_open_goals : t -> int (** Runs a tactic on the current proof. Raises [NoCurrentProof] is there is no current proof. @@ -115,24 +115,24 @@ val with_current_proof : val simple_with_current_proof : (unit Proofview.tactic -> Proof.t -> Proof.t) -> stack -> stack -val with_proof : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> pstate -> pstate * 'a -val modify_proof : (Proof.t -> Proof.t) -> pstate -> pstate +val with_proof : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> t -> t * 'a +val modify_proof : (Proof.t -> Proof.t) -> t -> t -val with_current_pstate : (pstate -> pstate * 'a) -> stack -> stack * 'a -val modify_current_pstate : (pstate -> pstate) -> stack -> stack +val with_current_pstate : (t -> t * 'a) -> stack -> stack * 'a +val modify_current_pstate : (t -> t) -> stack -> stack (** Sets the tactic to be used when a tactic line is closed with [...] *) -val set_endline_tactic : Genarg.glob_generic_argument -> pstate -> pstate +val set_endline_tactic : Genarg.glob_generic_argument -> t -> t (** Sets the section variables assumed by the proof, returns its closure * (w.r.t. type dependencies and let-ins covered by it) + a list of * ids to be cleared *) -val set_used_variables : pstate -> - Names.Id.t list -> (Constr.named_context * Names.lident list) * pstate +val set_used_variables : t -> + Names.Id.t list -> (Constr.named_context * Names.lident list) * t -val get_used_variables : pstate -> Constr.named_context option +val get_used_variables : t -> Constr.named_context option (** Get the universe declaration associated to the current proof. *) -val get_universe_decl : pstate -> UState.universe_decl +val get_universe_decl : t -> UState.universe_decl val copy_terminators : src:stack -> tgt:stack -> stack diff --git a/tactics/hints.mli b/tactics/hints.mli index 396c3e2fed..7b8f96cdd8 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -292,7 +292,7 @@ val wrap_hint_warning_fun : env -> evar_map -> (** Printing hints *) val pr_searchtable : env -> evar_map -> Pp.t -val pr_applicable_hint : Proof_global.pstate -> Pp.t +val pr_applicable_hint : Proof_global.t -> Pp.t val pr_hint_ref : env -> evar_map -> GlobRef.t -> Pp.t val pr_hint_db_by_name : env -> evar_map -> hint_db_name -> Pp.t val pr_hint_db_env : env -> evar_map -> Hint_db.t -> Pp.t diff --git a/user-contrib/Ltac2/tac2entries.mli b/user-contrib/Ltac2/tac2entries.mli index 273cf02c9b..80d48f67ba 100644 --- a/user-contrib/Ltac2/tac2entries.mli +++ b/user-contrib/Ltac2/tac2entries.mli @@ -29,7 +29,7 @@ val register_struct val register_notation : ?local:bool -> sexpr list -> int option -> raw_tacexpr -> unit -val perform_eval : pstate:Proof_global.pstate option -> raw_tacexpr -> unit +val perform_eval : pstate:Proof_global.t option -> raw_tacexpr -> unit (** {5 Notations} *) @@ -51,7 +51,7 @@ val print_ltac : Libnames.qualid -> unit (** {5 Eval loop} *) (** Evaluate a tactic expression in the current environment *) -val call : pstate:Proof_global.pstate -> default:bool -> raw_tacexpr -> Proof_global.pstate +val call : pstate:Proof_global.t -> default:bool -> raw_tacexpr -> Proof_global.t (** {5 Toplevel exceptions} *) diff --git a/vernac/classes.mli b/vernac/classes.mli index d441fd342c..daba78217b 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -43,7 +43,7 @@ val new_instance : -> ?tac:unit Proofview.tactic -> ?hook:(GlobRef.t -> unit) -> Hints.hint_info_expr - -> Id.t * Proof_global.pstate option (* May open a proof *) + -> Id.t * Proof_global.t option (* May open a proof *) val declare_new_instance : ?global:bool (** Not global by default. *) diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index d36593332e..9e376c8f96 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -20,11 +20,11 @@ open Vernacexpr val do_fixpoint : (* When [false], assume guarded. *) - locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> Proof_global.pstate option + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> Proof_global.t option val do_cofixpoint : (* When [false], assume guarded. *) - locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> Proof_global.pstate option + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> Proof_global.t option (************************************************************************) (** Internal API *) @@ -85,14 +85,14 @@ val declare_fixpoint : recursive_preentry * UState.universe_decl * UState.t * (Constr.rel_context * Impargs.manual_implicits * int option) list -> Proof_global.lemma_possible_guards -> decl_notation list -> - Proof_global.pstate option + Proof_global.t option val declare_cofixpoint : locality -> polymorphic -> recursive_preentry * UState.universe_decl * UState.t * (Constr.rel_context * Impargs.manual_implicits * int option) list -> decl_notation list -> - Proof_global.pstate option + Proof_global.t option (** Very private function, do not use *) val compute_possible_guardness_evidences : diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index e613b79c7b..c4c609e824 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -41,13 +41,13 @@ val start_proof : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map ?terminator:(?hook:declaration_hook -> Proof_global.lemma_possible_guards -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> ?compute_guard:Proof_global.lemma_possible_guards -> - ?hook:declaration_hook -> EConstr.types -> Proof_global.pstate + ?hook:declaration_hook -> EConstr.types -> Proof_global.t val start_proof_com : program_mode:bool -> ?inference_hook:Pretyping.inference_hook -> ?hook:declaration_hook -> goal_kind -> Vernacexpr.proof_expr list - -> Proof_global.pstate + -> Proof_global.t val start_proof_with_initialization : ?hook:declaration_hook -> @@ -55,7 +55,7 @@ val start_proof_with_initialization : (bool * Proof_global.lemma_possible_guards * unit Proofview.tactic list option) option -> (Id.t (* name of thm *) * (EConstr.types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list - -> int list option -> Proof_global.pstate + -> int list option -> Proof_global.t val standard_proof_terminator : ?hook:declaration_hook -> Proof_global.lemma_possible_guards -> @@ -72,7 +72,7 @@ val initialize_named_context_for_proof : unit -> Environ.named_context_val val save_proof_admitted : ?proof:Proof_global.closed_proof - -> pstate:Proof_global.pstate + -> pstate:Proof_global.t -> unit val save_proof_proved @@ -83,7 +83,7 @@ val save_proof_proved -> Proof_global.stack option val save_pstate_proved - : pstate:Proof_global.pstate + : pstate:Proof_global.t -> opaque:Proof_global.opacity_flag -> idopt:Names.lident option -> unit diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 7db094a75d..3b77039de5 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -88,12 +88,12 @@ val add_mutual_definitions : val obligation : int * Names.Id.t option * Constrexpr.constr_expr option -> Genarg.glob_generic_argument option - -> Proof_global.pstate + -> Proof_global.t val next_obligation : Names.Id.t option -> Genarg.glob_generic_argument option - -> Proof_global.pstate + -> Proof_global.t val solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> progress (* Number of remaining obligations to be solved for this program *) diff --git a/vernac/search.mli b/vernac/search.mli index f8074a67ff..0f94ddc5b6 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -39,13 +39,13 @@ val search_about_filter : glob_search_about_item -> filter_function goal and the global environment for things matching [pattern] and satisfying module exclude/include clauses of [modinout]. *) -val search_by_head : ?pstate:Proof_global.pstate -> int option -> constr_pattern -> DirPath.t list * bool +val search_by_head : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_rewrite : ?pstate:Proof_global.pstate -> int option -> constr_pattern -> DirPath.t list * bool +val search_rewrite : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_pattern : ?pstate:Proof_global.pstate -> int option -> constr_pattern -> DirPath.t list * bool +val search_pattern : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_about : ?pstate:Proof_global.pstate -> int option -> (bool * glob_search_about_item) list +val search_about : ?pstate:Proof_global.t -> int option -> (bool * glob_search_about_item) list -> DirPath.t list * bool -> display_function -> unit type search_constraint = @@ -66,12 +66,12 @@ type 'a coq_object = { coq_object_object : 'a; } -val interface_search : ?pstate:Proof_global.pstate -> ?glnum:int -> (search_constraint * bool) list -> +val interface_search : ?pstate:Proof_global.t -> ?glnum:int -> (search_constraint * bool) list -> constr coq_object list (** {6 Generic search function} *) -val generic_search : ?pstate:Proof_global.pstate -> int option -> display_function -> unit +val generic_search : ?pstate:Proof_global.t -> int option -> display_function -> unit (** This function iterates over all hypothesis of the goal numbered [glnum] (if present) and all known declarations. *) diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 8d15191ebe..c88de1181a 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -1114,7 +1114,7 @@ let vernac_set_end_tac ~pstate tac = (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) Proof_global.set_endline_tactic tac pstate -let vernac_set_used_variables ~(pstate : Proof_global.pstate) e : Proof_global.pstate = +let vernac_set_used_variables ~(pstate : Proof_global.t) e : Proof_global.t = let env = Global.env () in let initial_goals pf = Proofview.initial_goals Proof.(data pf).Proof.entry in let tys = @@ -2715,11 +2715,11 @@ let interp ?(verbosely=true) ?proof ~st cmd = type functional_vernac = | VtDefault of (unit -> unit) | VtModifyProofStack of (pstate:Proof_global.stack option -> Proof_global.stack option) - | VtMaybeOpenProof of (unit -> Proof_global.pstate option) - | VtOpenProof of (unit -> Proof_global.pstate) - | VtModifyProof of (pstate:Proof_global.pstate -> Proof_global.pstate) - | VtReadProofOpt of (pstate:Proof_global.pstate option -> unit) - | VtReadProof of (pstate:Proof_global.pstate -> unit) + | VtMaybeOpenProof of (unit -> Proof_global.t option) + | VtOpenProof of (unit -> Proof_global.t) + | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) + | VtReadProofOpt of (pstate:Proof_global.t option -> unit) + | VtReadProof of (pstate:Proof_global.t -> unit) let interp_functional_vernac c ~pstate = let open Proof_global in diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 552be6e407..06a08e5e6b 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -44,9 +44,9 @@ val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr (** Helper *) val vernac_require_open_proof : pstate:Proof_global.stack option -> (pstate:Proof_global.stack -> 'a) -> 'a -val with_pstate : pstate:Proof_global.stack option -> (pstate:Proof_global.pstate -> 'a) -> 'a +val with_pstate : pstate:Proof_global.stack option -> (pstate:Proof_global.t -> 'a) -> 'a -val modify_pstate : pstate:Proof_global.stack option -> (pstate:Proof_global.pstate -> Proof_global.pstate) -> Proof_global.stack option +val modify_pstate : pstate:Proof_global.stack option -> (pstate:Proof_global.t -> Proof_global.t) -> Proof_global.stack option (* Flag set when the test-suite is called. Its only effect to display verbose information for `Fail` *) @@ -57,11 +57,11 @@ val test_mode : bool ref type functional_vernac = | VtDefault of (unit -> unit) | VtModifyProofStack of (pstate:Proof_global.stack option -> Proof_global.stack option) - | VtMaybeOpenProof of (unit -> Proof_global.pstate option) - | VtOpenProof of (unit -> Proof_global.pstate) - | VtModifyProof of (pstate:Proof_global.pstate -> Proof_global.pstate) - | VtReadProofOpt of (pstate:Proof_global.pstate option -> unit) - | VtReadProof of (pstate:Proof_global.pstate -> unit) + | VtMaybeOpenProof of (unit -> Proof_global.t option) + | VtOpenProof of (unit -> Proof_global.t) + | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) + | VtReadProofOpt of (pstate:Proof_global.t option -> unit) + | VtReadProof of (pstate:Proof_global.t -> unit) val interp_functional_vernac : functional_vernac diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index f52cd6a829..b0f3c572e5 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -25,7 +25,7 @@ type t = { shallow : bool (* is the state trimmed down (libstack) *) } -val pstate : t -> Proof_global.pstate option +val pstate : t -> Proof_global.t option val freeze_interp_state : marshallable:bool -> t val unfreeze_interp_state : t -> unit -- cgit v1.2.3 From 80602ad2acb5f497594b2e76b03b73a080847a07 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Tue, 21 May 2019 13:52:52 +0200 Subject: Replace ModifyProofStack by CloseProof The only use of ModifyProofStack was in paramcoq for closing a proof. --- coqpp/coqpp_main.ml | 2 +- vernac/vernacentries.ml | 7 +++++-- vernac/vernacentries.mli | 2 +- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index b118d9ec00..48f9ed30b0 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -358,7 +358,7 @@ let print_atts_right fmt = function fprintf fmt "(Attributes.parse %s%a atts)" nota aux atts let understand_state = function - | "proof_stack" -> "VtModifyProofStack", false + | "close_proof" -> "VtCloseProof", false | "maybe_open_proof" -> "VtMaybeOpenProof", true | "open_proof" -> "VtOpenProof", true | "proof" -> "VtModifyProof", false diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index c88de1181a..77e8a92cc1 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -2714,7 +2714,7 @@ let interp ?(verbosely=true) ?proof ~st cmd = type functional_vernac = | VtDefault of (unit -> unit) - | VtModifyProofStack of (pstate:Proof_global.stack option -> Proof_global.stack option) + | VtCloseProof of (pstate:Proof_global.t -> unit) | VtMaybeOpenProof of (unit -> Proof_global.t option) | VtOpenProof of (unit -> Proof_global.t) | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) @@ -2725,7 +2725,10 @@ let interp_functional_vernac c ~pstate = let open Proof_global in match c with | VtDefault f -> f (); pstate - | VtModifyProofStack f -> f ~pstate + | VtCloseProof f -> + vernac_require_open_proof ~pstate (fun ~pstate -> + f ~pstate:(Proof_global.get_current_pstate pstate); + Proof_global.discard_current pstate) | VtMaybeOpenProof f -> let proof = f () in let pstate = maybe_push ~ontop:pstate proof in diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 06a08e5e6b..ca3a962319 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -56,7 +56,7 @@ val test_mode : bool ref type functional_vernac = | VtDefault of (unit -> unit) - | VtModifyProofStack of (pstate:Proof_global.stack option -> Proof_global.stack option) + | VtCloseProof of (pstate:Proof_global.t -> unit) | VtMaybeOpenProof of (unit -> Proof_global.t option) | VtOpenProof of (unit -> Proof_global.t) | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) -- cgit v1.2.3 From 96231a23a9b76b17541572defb6089e23e80c474 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Mon, 6 May 2019 14:02:53 +0200 Subject: Overlays for coq/coq#10050 (proof_global API changes) --- .../user-overlays/10050-SkySkimmer-pass-less-ontop.sh | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100644 dev/ci/user-overlays/10050-SkySkimmer-pass-less-ontop.sh diff --git a/dev/ci/user-overlays/10050-SkySkimmer-pass-less-ontop.sh b/dev/ci/user-overlays/10050-SkySkimmer-pass-less-ontop.sh new file mode 100644 index 0000000000..0c3f1eefed --- /dev/null +++ b/dev/ci/user-overlays/10050-SkySkimmer-pass-less-ontop.sh @@ -0,0 +1,18 @@ +if [ "$CI_PULL_REQUEST" = "10050" ] || [ "$CI_BRANCH" = "pass-less-ontop" ]; then + + elpi_CI_REF=pass-less-ontop + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + + equations_CI_REF=pass-less-ontop + equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations + + mtac2_CI_REF=pass-less-ontop + mtac2_CI_GITURL=https://github.com/SkySkimmer/Mtac2 + + paramcoq_CI_REF=pass-less-ontop + paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq + + quickchick_CI_REF=pass-less-ontop + quickchick_CI_GITURL=https://github.com/SkySkimmer/QuickChick + +fi -- cgit v1.2.3 From 3b7509b96273f4e412b747e0c55dd193f38fd418 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Tue, 21 May 2019 23:06:40 +0200 Subject: VernacExtend produces vernac_interp_phase ADT (old name functional_vernac) + hide interp_functional_vernac in vernacentries --- coqpp/coqpp_main.ml | 11 ++++----- dev/top_printers.ml | 4 ++-- vernac/vernacentries.ml | 60 ++++++++++++++++++++---------------------------- vernac/vernacentries.mli | 16 ------------- vernac/vernacextend.ml | 15 +++++++++--- vernac/vernacextend.mli | 11 ++++++++- 6 files changed, 53 insertions(+), 64 deletions(-) diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 48f9ed30b0..d6ae0a7d6f 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -369,22 +369,19 @@ let understand_state = function let print_body_state state fmt r = let state = match r.vernac_state with Some _ as s -> s | None -> state in match state with - | None -> fprintf fmt "Vernacentries.VtDefault (fun () -> %a)" print_code r.vernac_body + | None -> fprintf fmt "Vernacextend.VtDefault (fun () -> %a)" print_code r.vernac_body | Some "CUSTOM" -> print_code fmt r.vernac_body | Some state -> let state, unit_wrap = understand_state state in - fprintf fmt "Vernacentries.%s (%s%a)" state (if unit_wrap then "fun () ->" else "") + fprintf fmt "Vernacextend.%s (%s%a)" state (if unit_wrap then "fun () ->" else "") print_code r.vernac_body -let print_body_wrapper state fmt r = - fprintf fmt "Vernacentries.interp_functional_vernac (%a)" (print_body_state state) r - let print_body_fun state fmt r = fprintf fmt "let coqpp_body %a%a = @[%a@] in " - print_binders r.vernac_toks print_atts_left r.vernac_atts (print_body_wrapper state) r + print_binders r.vernac_toks print_atts_left r.vernac_atts (print_body_state state) r let print_body state fmt r = - fprintf fmt "@[(%afun %a~atts@ ~pstate@ -> coqpp_body %a%a ~pstate)@]" + fprintf fmt "@[(%afun %a~atts@ -> coqpp_body %a%a)@]" (print_body_fun state) r print_binders r.vernac_toks print_binders r.vernac_toks print_atts_right r.vernac_atts diff --git a/dev/top_printers.ml b/dev/top_printers.ml index db444a9b78..4ce87faaa1 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -532,7 +532,7 @@ let _ = let open Vernacextend in let ty_constr = Extend.TUentry (get_arg_tag Stdarg.wit_constr) in let cmd_sig = TyTerminal("PrintConstr", TyNonTerminal(ty_constr, TyNil)) in - let cmd_fn c ~atts ~pstate = in_current_context econstr_display c; pstate in + let cmd_fn c ~atts = VtDefault (fun () -> in_current_context econstr_display c) in let cmd_class _ = VtQuery,VtNow in let cmd : ty_ml = TyML (false, cmd_sig, cmd_fn, Some cmd_class) in vernac_extend ~command:"PrintConstr" [cmd] @@ -541,7 +541,7 @@ let _ = let open Vernacextend in let ty_constr = Extend.TUentry (get_arg_tag Stdarg.wit_constr) in let cmd_sig = TyTerminal("PrintPureConstr", TyNonTerminal(ty_constr, TyNil)) in - let cmd_fn c ~atts ~pstate = in_current_context print_pure_econstr c; pstate in + let cmd_fn c ~atts = VtDefault (fun () -> in_current_context print_pure_econstr c) in let cmd_class _ = VtQuery,VtNow in let cmd : ty_ml = TyML (false, cmd_sig, cmd_fn, Some cmd_class) in vernac_extend ~command:"PrintPureConstr" [cmd] diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 77e8a92cc1..949ddfc3ee 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -2295,6 +2295,30 @@ let locate_if_not_already ?loc (e, info) = exception End_of_input +let vernac_interp_phase c ~pstate = + let open Proof_global in + let open Vernacextend in + match c with + | VtDefault f -> f (); pstate + | VtCloseProof f -> + vernac_require_open_proof ~pstate (fun ~pstate -> + f ~pstate:(Proof_global.get_current_pstate pstate); + Proof_global.discard_current pstate) + | VtMaybeOpenProof f -> + let proof = f () in + let pstate = maybe_push ~ontop:pstate proof in + pstate + | VtOpenProof f -> + Some (push ~ontop:pstate (f ())) + | VtModifyProof f -> + modify_pstate f ~pstate + | VtReadProofOpt f -> + f ~pstate:(Option.map get_current_pstate pstate); + pstate + | VtReadProof f -> + with_pstate ~pstate f; + pstate + (* "locality" is the prefix "Local" attribute, while the "local" component * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility. @@ -2629,7 +2653,7 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.stack option = (* Extensions *) | VernacExtend (opn,args) -> - Vernacextend.call ~atts opn args ~pstate + vernac_interp_phase (Vernacextend.call ~atts opn args) ~pstate (* XXX: This won't properly set the proof mode, as of today, it is controlled by the STM. Thus, we would need access information from @@ -2709,37 +2733,3 @@ let interp ?(verbosely=true) ?proof ~st cmd = let exn = locate_if_not_already ?loc:cmd.CAst.loc exn in Vernacstate.invalidate_cache (); iraise exn - -(* mlg helpers *) - -type functional_vernac = - | VtDefault of (unit -> unit) - | VtCloseProof of (pstate:Proof_global.t -> unit) - | VtMaybeOpenProof of (unit -> Proof_global.t option) - | VtOpenProof of (unit -> Proof_global.t) - | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) - | VtReadProofOpt of (pstate:Proof_global.t option -> unit) - | VtReadProof of (pstate:Proof_global.t -> unit) - -let interp_functional_vernac c ~pstate = - let open Proof_global in - match c with - | VtDefault f -> f (); pstate - | VtCloseProof f -> - vernac_require_open_proof ~pstate (fun ~pstate -> - f ~pstate:(Proof_global.get_current_pstate pstate); - Proof_global.discard_current pstate) - | VtMaybeOpenProof f -> - let proof = f () in - let pstate = maybe_push ~ontop:pstate proof in - pstate - | VtOpenProof f -> - Some (push ~ontop:pstate (f ())) - | VtModifyProof f -> - modify_pstate f ~pstate - | VtReadProofOpt f -> - f ~pstate:(Option.map get_current_pstate pstate); - pstate - | VtReadProof f -> - with_pstate ~pstate f; - pstate diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index ca3a962319..d94ddc1aaf 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -51,19 +51,3 @@ val modify_pstate : pstate:Proof_global.stack option -> (pstate:Proof_global.t - (* Flag set when the test-suite is called. Its only effect to display verbose information for `Fail` *) val test_mode : bool ref - -(** For mlg *) - -type functional_vernac = - | VtDefault of (unit -> unit) - | VtCloseProof of (pstate:Proof_global.t -> unit) - | VtMaybeOpenProof of (unit -> Proof_global.t option) - | VtOpenProof of (unit -> Proof_global.t) - | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) - | VtReadProofOpt of (pstate:Proof_global.t option -> unit) - | VtReadProof of (pstate:Proof_global.t -> unit) - -val interp_functional_vernac - : functional_vernac - -> pstate:Proof_global.stack option - -> Proof_global.stack option diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 644413cbb9..cf704206af 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -53,7 +53,16 @@ type vernac_when = | VtLater type vernac_classification = vernac_type * vernac_when -type vernac_command = atts:Attributes.vernac_flags -> pstate:Proof_global.stack option -> Proof_global.stack option +type vernac_interp_phase = + | VtDefault of (unit -> unit) + | VtCloseProof of (pstate:Proof_global.t -> unit) + | VtMaybeOpenProof of (unit -> Proof_global.t option) + | VtOpenProof of (unit -> Proof_global.t) + | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) + | VtReadProofOpt of (pstate:Proof_global.t option -> unit) + | VtReadProof of (pstate:Proof_global.t -> unit) + +type vernac_command = atts:Attributes.vernac_flags -> vernac_interp_phase type plugin_args = Genarg.raw_generic_argument list @@ -83,7 +92,7 @@ let warn_deprecated_command = (* Interpretation of a vernac command *) -let call opn converted_args ~atts ~pstate = +let call opn converted_args ~atts = let phase = ref "Looking up command" in try let depr, callback = vinterp_map opn in @@ -99,7 +108,7 @@ let call opn converted_args ~atts ~pstate = phase := "Checking arguments"; let hunk = callback converted_args in phase := "Executing command"; - hunk ~atts ~pstate + hunk ~atts with | reraise -> let reraise = CErrors.push reraise in diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 46cee30a1e..4d885a3afc 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -71,7 +71,16 @@ type vernac_classification = vernac_type * vernac_when (** Interpretation of extended vernac phrases. *) -type vernac_command = atts:Attributes.vernac_flags -> pstate:Proof_global.stack option -> Proof_global.stack option +type vernac_interp_phase = + | VtDefault of (unit -> unit) + | VtCloseProof of (pstate:Proof_global.t -> unit) + | VtMaybeOpenProof of (unit -> Proof_global.t option) + | VtOpenProof of (unit -> Proof_global.t) + | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) + | VtReadProofOpt of (pstate:Proof_global.t option -> unit) + | VtReadProof of (pstate:Proof_global.t -> unit) + +type vernac_command = atts:Attributes.vernac_flags -> vernac_interp_phase type plugin_args = Genarg.raw_generic_argument list -- cgit v1.2.3 From 0f1814bcbaafbd93d7c7587eef8826a80b65477f Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 22 May 2019 17:52:19 +0200 Subject: [function] always open a proof when used with `wf` or `measure` --- .../10215-rm-maybe-open-proof.rst | 5 +++ doc/sphinx/language/gallina-extensions.rst | 2 +- plugins/funind/g_indfun.mlg | 47 +++++++++++++++------- plugins/funind/indfun.ml | 36 ++++++++++++----- plugins/funind/indfun.mli | 6 ++- plugins/funind/recdef.ml | 13 +++--- plugins/funind/recdef.mli | 24 ++++++----- test-suite/bugs/closed/bug_1618.v | 1 + test-suite/bugs/closed/bug_4306.v | 2 + 9 files changed, 92 insertions(+), 44 deletions(-) create mode 100644 doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst diff --git a/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst b/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst new file mode 100644 index 0000000000..53828db951 --- /dev/null +++ b/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst @@ -0,0 +1,5 @@ +- Function always opens a proof when used with a ``measure`` or ``wf`` + annotation, see Description of the changes, with possible link to + :ref:`advanced-recursive-functions` of the updated documentation + (`#10215 `_, + by Enrico Tassi). diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 8c5ad785e4..c93984661e 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -737,7 +737,7 @@ used by ``Function``. A more precise description is given below. decreases at each recursive call of :token:`term`. The order must be well-founded. Parameters of the function are bound in :token:`term`. - Depending on the annotation, the user is left with some proof + If the annotation is ``measure`` or ``fw``, the user is left with some proof obligations that will be used to define the function. These proofs are: proofs that each recursive call is actually decreasing with respect to the given criteria, and (if the criteria is `wf`) a proof diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index bdd30aae0a..833ff9f1ed 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -173,24 +173,41 @@ let () = let raw_printer env sigma _ _ _ (loc,body) = Ppvernac.pr_rec_definition body in Pptactic.declare_extra_vernac_genarg_pprule wit_function_rec_definition_loc raw_printer +let is_proof_termination_interactively_checked recsl = + List.exists (function + | _,((_,( Some { CAst.v = CMeasureRec _ } + | Some { CAst.v = CWfRec _}),_,_,_),_) -> true + | _,((_,Some { CAst.v = CStructRec _ },_,_,_),_) + | _,((_,None,_,_,_),_) -> false) recsl + +let classify_as_Fixpoint recsl = + Vernac_classifier.classify_vernac + (Vernacexpr.(CAst.make @@ VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) + +let classify_funind recsl = + match classify_as_Fixpoint recsl with + | Vernacextend.VtSideff ids, _ + when is_proof_termination_interactively_checked recsl -> + Vernacextend.(VtStartProof (GuaranteesOpacity, ids), VtLater) + | x -> x + +let is_interactive recsl = + match classify_funind recsl with + | Vernacextend.VtStartProof _, _ -> true + | _ -> false + } -(* TASSI: n'importe quoi ! *) -VERNAC COMMAND EXTEND Function STATE maybe_open_proof +VERNAC COMMAND EXTEND Function STATE CUSTOM | ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] - => { let hard = List.exists (function - | _,((_,(Some { CAst.v = CMeasureRec _ } - | Some { CAst.v = CWfRec _}),_,_,_),_) -> true - | _,((_,Some { CAst.v = CStructRec _ },_,_,_),_) - | _,((_,None,_,_,_),_) -> false) recsl in - match - Vernac_classifier.classify_vernac - (Vernacexpr.(CAst.make @@ VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) - with - | Vernacextend.VtSideff ids, _ when hard -> - Vernacextend.(VtStartProof (GuaranteesOpacity, ids), VtLater) - | x -> x } - -> { do_generate_principle false (List.map snd recsl) } + => { classify_funind recsl } + -> { + if is_interactive recsl then + Vernacextend.VtOpenProof (fun () -> + do_generate_principle_interactive (List.map snd recsl)) + else + Vernacextend.VtDefault (fun () -> + do_generate_principle (List.map snd recsl)) } END { diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 7c6669d0fc..bb6db1f5cf 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -459,7 +459,7 @@ let generate_correction_proof_wf f_ref tcc_lemma_ref tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation -let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body +let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body pre_hook = let type_of_f = Constrexpr_ops.mkCProdN args ret_type in @@ -500,8 +500,8 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas (* No proof done *) () in - Recdef.recursive_definition - is_mes fname rec_impls + Recdef.recursive_definition ~interactive_proof + ~is_mes fname rec_impls type_of_f wf_rel_expr rec_arg_num @@ -510,7 +510,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas using_lemmas -let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas args ret_type body = +let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas args ret_type body = let wf_arg_type,wf_arg = match wf_arg with | None -> @@ -570,7 +570,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas in wf_rel_with_mes,false in - register_wf ~is_mes:is_mes fname rec_impls wf_rel_from_mes wf_arg + register_wf interactive_proof ~is_mes:is_mes fname rec_impls wf_rel_from_mes wf_arg using_lemmas args ret_type body let map_option f = function @@ -633,7 +633,7 @@ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacex fixpoint_exprl_with_new_bl -let do_generate_principle pconstants on_error register_built interactive_proof +let do_generate_principle_aux pconstants on_error register_built interactive_proof (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) : Proof_global.t option = List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl; let pstate, _is_struct = @@ -660,7 +660,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof true in if register_built - then register_wf name rec_impls wf_rel wf_x.CAst.v using_lemmas args types body pre_hook, false + then register_wf interactive_proof name rec_impls wf_rel wf_x.CAst.v using_lemmas args types body pre_hook, false else None, false |[((_,Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)},_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},_),_,args,types,body)),_) as fixpoint_expr = @@ -684,7 +684,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof true in if register_built - then register_mes name rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook, true + then register_mes interactive_proof name rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook, true else None, true | _ -> List.iter (function ((_na,ord,_args,_body,_type),_not) -> @@ -902,11 +902,27 @@ let make_graph (f_ref : GlobRef.t) = [((CAst.make id,None),None,nal_tas,t,Some b),[]] in let mp = Constant.modpath c in - let pstate = do_generate_principle [c,Univ.Instance.empty] error_error false false expr_list in + let pstate = do_generate_principle_aux [c,Univ.Instance.empty] error_error false false expr_list in assert (Option.is_empty pstate); (* We register the infos *) List.iter (fun ((({CAst.v=id},_),_,_,_,_),_) -> add_Function false (Constant.make2 mp (Label.of_id id))) expr_list) -let do_generate_principle = do_generate_principle [] warning_error true +(* *************** statically typed entrypoints ************************* *) + +let do_generate_principle_interactive fixl : Proof_global.t = + match + do_generate_principle_aux [] warning_error true true fixl + with + | Some pstate -> pstate + | None -> + CErrors.anomaly + (Pp.str"indfun: leaving no open proof in interactive mode") + +let do_generate_principle fixl : unit = + match do_generate_principle_aux [] warning_error true false fixl with + | Some _pstate -> + CErrors.anomaly + (Pp.str"indfun: leaving a goal open in non-interactive mode") + | None -> () diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index 47d37b29a5..1ba245a45d 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -6,9 +6,11 @@ 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 : - bool -> + (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> unit + +val do_generate_principle_interactive : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> - Proof_global.t option + Proof_global.t val functional_induction : bool -> diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 5a682e7231..e2321d233c 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1395,12 +1395,10 @@ let open_new_goal pstate build_proof sigma using_lemmas ref_ goal_name (gls_type ) tclIDTAC) g end) pstate in - try - Some (fst @@ by (Proofview.V82.tactic tclIDTAC) pstate) (* raises UserError _ if the proof is complete *) - with UserError _ -> - (defined pstate; None) + if Proof_global.get_open_goals pstate = 0 then (defined pstate; None) else Some pstate let com_terminate + interactive_proof tcc_lemma_name tcc_lemma_ref is_mes @@ -1430,8 +1428,8 @@ let com_terminate with EmptySubgoals -> (* a non recursive function declared with measure ! *) tcc_lemma_ref := Not_needed; - defined pstate; - None + if interactive_proof then Some pstate + else (defined pstate; None) let start_equation (f:GlobRef.t) (term_f:GlobRef.t) (cont_tactic:Id.t list -> tactic) g = @@ -1494,7 +1492,7 @@ let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation (* Pp.msgnl (fun _ _ -> str "eqn finished"); *) -let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq +let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : Proof_global.t option = let open Term in let open Constr in @@ -1585,6 +1583,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num (* XXX STATE Why do we need this... why is the toplevel protection not enough *) funind_purify (fun () -> let pstate = com_terminate + interactive_proof tcc_lemma_name tcc_lemma_constr is_mes functional_ref diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index 90f9c449b1..b92ac3a0ec 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -5,13 +5,19 @@ val tclUSER_if_not_mes : bool -> Names.Id.t list option -> Tacmach.tactic + val recursive_definition : -bool -> - Names.Id.t -> - Constrintern.internalization_env -> - Constrexpr.constr_expr -> - Constrexpr.constr_expr -> - int -> Constrexpr.constr_expr -> (pconstant -> - Indfun_common.tcc_lemma_value ref -> - pconstant -> - pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> Constrexpr.constr_expr list -> Proof_global.t option + interactive_proof:bool -> + is_mes:bool -> + Names.Id.t -> + Constrintern.internalization_env -> + Constrexpr.constr_expr -> + Constrexpr.constr_expr -> + int -> + Constrexpr.constr_expr -> + (pconstant -> + Indfun_common.tcc_lemma_value ref -> + pconstant -> + pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> + Constrexpr.constr_expr list -> + Proof_global.t option diff --git a/test-suite/bugs/closed/bug_1618.v b/test-suite/bugs/closed/bug_1618.v index a7be12e26f..041055a38f 100644 --- a/test-suite/bugs/closed/bug_1618.v +++ b/test-suite/bugs/closed/bug_1618.v @@ -20,3 +20,4 @@ a := match a return (P a) with | A1 n => f n end. +Proof. Defined. diff --git a/test-suite/bugs/closed/bug_4306.v b/test-suite/bugs/closed/bug_4306.v index 80c348d207..f1bce04451 100644 --- a/test-suite/bugs/closed/bug_4306.v +++ b/test-suite/bugs/closed/bug_4306.v @@ -30,3 +30,5 @@ Function bar (xys : (list nat * list nat)) {measure (fun xys => length (fst xys) | Gt => y :: foo (xs, ys') end end. +Proof. +Defined. -- cgit v1.2.3 From 2ebd73901edb94030aa804572cbe86d486ca6732 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 22 May 2019 17:50:44 +0200 Subject: [rewrite] Add Morphism syntax made different for module type parameters --- .../10215-rm-maybe-open-proof.rst | 7 +++ doc/sphinx/addendum/generalized-rewriting.rst | 7 +++ plugins/ltac/g_rewrite.mlg | 12 +++-- plugins/ltac/rewrite.ml | 62 ++++++++++++---------- plugins/ltac/rewrite.mli | 3 +- 5 files changed, 57 insertions(+), 34 deletions(-) diff --git a/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst b/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst index 53828db951..12d458a72c 100644 --- a/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst +++ b/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst @@ -3,3 +3,10 @@ :ref:`advanced-recursive-functions` of the updated documentation (`#10215 `_, by Enrico Tassi). + +- The legacy command Add Morphism always opens a proof and cannot be used + inside a module type. In order to declare a module type parameter that + happens to be a morphism, use ``Parameter Morphism``. See + :ref:`deprecated_syntax_for_generalized_rewriting` for the updated + documentation (`#10215 `_, + by Enrico Tassi). diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index e58049b8d0..2ea0861e47 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -563,6 +563,7 @@ Printing relations and morphisms of morphisms, the :cmd:`Print Instances` command can be useful to understand what additional morphisms should be registered. +.. _deprecated_syntax_for_generalized_rewriting: Deprecated syntax and backward incompatibilities ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -589,6 +590,12 @@ Deprecated syntax and backward incompatibilities bi-implication in place of a simple implication. In practice, porting an old development to the new semantics is usually quite simple. +.. cmd:: Declare Morphism @ident : @ident + :name: Declare Morphism + + This commands is to be used in a module type to declare a parameter that + is a morphism. + Notice that several limitations of the old implementation have been lifted. In particular, it is now possible to declare several relations with the same carrier and several signatures for the same morphism. diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index bb29323858..1a84158df7 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -276,10 +276,14 @@ VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF { add_setoid atts binders a aeq t n } - | #[ atts = rewrite_attributes; ] ![ maybe_open_proof ] [ "Add" "Morphism" constr(m) ":" ident(n) ] - (* This command may or may not open a goal *) - => { (if Lib.is_modtype() then VtSideff([n]) else VtStartProof(GuaranteesOpacity, [n])), VtLater } - -> { add_morphism_infer atts m n } + | #[ atts = rewrite_attributes; ] ![ open_proof ] [ "Add" "Morphism" constr(m) ":" ident(n) ] + => { VtStartProof(GuaranteesOpacity, [n]), VtLater } + -> { if Lib.is_modtype () then + CErrors.user_err Pp.(str "Add Morphism cannot be used in a module type. Use Parameter Morphism instead."); + add_morphism_interactive atts m n } + | #[ atts = rewrite_attributes; ] [ "Declare" "Morphism" constr(m) ":" ident(n) ] + => { VtSideff([n]), VtLater } + -> { add_morphism_as_parameter atts m n } | #[ atts = rewrite_attributes; ] ![ open_proof ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] => { VtStartProof(GuaranteesOpacity,[n]), VtLater } -> { add_morphism atts [] m s n } diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 26d477fee0..c568f63903 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1973,42 +1973,46 @@ let warn_add_morphism_deprecated = CWarnings.create ~name:"add-morphism" ~category:"deprecated" (fun () -> Pp.(str "Add Morphism f : id is deprecated, please use Add Morphism f with signature (...) as id")) -let add_morphism_infer atts m n : Proof_global.t option = +let add_morphism_as_parameter atts m n : unit = + init_setoid (); + let instance_id = add_suffix n "_Proper" in + let env = Global.env () in + let evd = Evd.from_env env in + let uctx, instance = build_morphism_signature env evd m in + let uctx = UState.univ_entry ~poly:atts.polymorphic uctx in + let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id + (Entries.ParameterEntry + (None,(instance,uctx),None), + Decl_kinds.IsAssumption Decl_kinds.Logical) + in + Classes.add_instance (Classes.mk_instance + (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (ConstRef cst)); + declare_projection n instance_id (ConstRef cst) + +let add_morphism_interactive atts m n : Proof_global.t = warn_add_morphism_deprecated ?loc:m.CAst.loc (); init_setoid (); let instance_id = add_suffix n "_Proper" in let env = Global.env () in let evd = Evd.from_env env in let uctx, instance = build_morphism_signature env evd m in - if Lib.is_modtype () then - let uctx = UState.univ_entry ~poly:atts.polymorphic uctx in - let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id - (Entries.ParameterEntry - (None,(instance,uctx),None), - Decl_kinds.IsAssumption Decl_kinds.Logical) - in + let kind = Decl_kinds.Global, atts.polymorphic, + Decl_kinds.DefinitionBody Decl_kinds.Instance + in + let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in + let hook _ _ _ = function + | Globnames.ConstRef cst -> Classes.add_instance (Classes.mk_instance - (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (ConstRef cst)); - declare_projection n instance_id (ConstRef cst); - None - else - let kind = Decl_kinds.Global, atts.polymorphic, - Decl_kinds.DefinitionBody Decl_kinds.Instance - in - let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in - let hook _ _ _ = function - | Globnames.ConstRef cst -> - Classes.add_instance (Classes.mk_instance - (PropGlobal.proper_class env evd) Hints.empty_hint_info - atts.global (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) - | _ -> assert false - in - let hook = Lemmas.mk_hook hook in - Flags.silently - (fun () -> - let pstate = Lemmas.start_proof ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) in - Some (fst Pfedit.(by (Tacinterp.interp tac) pstate))) () + (PropGlobal.proper_class env evd) Hints.empty_hint_info + atts.global (ConstRef cst)); + declare_projection n instance_id (ConstRef cst) + | _ -> assert false + in + let hook = Lemmas.mk_hook hook in + Flags.silently + (fun () -> + let pstate = Lemmas.start_proof ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) in + fst Pfedit.(by (Tacinterp.interp tac) pstate)) () let add_morphism atts binders m s n = init_setoid (); diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 5aabb946d5..3ef33c6dc9 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -101,7 +101,8 @@ val add_setoid -> Id.t -> unit -val add_morphism_infer : rewrite_attributes -> constr_expr -> Id.t -> Proof_global.t option +val add_morphism_interactive : rewrite_attributes -> constr_expr -> Id.t -> Proof_global.t +val add_morphism_as_parameter : rewrite_attributes -> constr_expr -> Id.t -> unit val add_morphism : rewrite_attributes -- cgit v1.2.3 From d77604cb06fcc8e8f38ef979627aa7a7138ef0f2 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 22 May 2019 18:30:31 +0200 Subject: [vernac] remove VtMaybeOpenProof --- coqpp/coqpp_main.ml | 1 - vernac/vernacentries.ml | 4 ---- vernac/vernacextend.ml | 1 - vernac/vernacextend.mli | 1 - 4 files changed, 7 deletions(-) diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index d6ae0a7d6f..d5aedfcbb1 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -359,7 +359,6 @@ let print_atts_right fmt = function let understand_state = function | "close_proof" -> "VtCloseProof", false - | "maybe_open_proof" -> "VtMaybeOpenProof", true | "open_proof" -> "VtOpenProof", true | "proof" -> "VtModifyProof", false | "proof_opt_query" -> "VtReadProofOpt", false diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 949ddfc3ee..da9fa35202 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -2304,10 +2304,6 @@ let vernac_interp_phase c ~pstate = vernac_require_open_proof ~pstate (fun ~pstate -> f ~pstate:(Proof_global.get_current_pstate pstate); Proof_global.discard_current pstate) - | VtMaybeOpenProof f -> - let proof = f () in - let pstate = maybe_push ~ontop:pstate proof in - pstate | VtOpenProof f -> Some (push ~ontop:pstate (f ())) | VtModifyProof f -> diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index cf704206af..2d3443d30a 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -56,7 +56,6 @@ type vernac_classification = vernac_type * vernac_when type vernac_interp_phase = | VtDefault of (unit -> unit) | VtCloseProof of (pstate:Proof_global.t -> unit) - | VtMaybeOpenProof of (unit -> Proof_global.t option) | VtOpenProof of (unit -> Proof_global.t) | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) | VtReadProofOpt of (pstate:Proof_global.t option -> unit) diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 4d885a3afc..f06f31d45b 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -74,7 +74,6 @@ type vernac_classification = vernac_type * vernac_when type vernac_interp_phase = | VtDefault of (unit -> unit) | VtCloseProof of (pstate:Proof_global.t -> unit) - | VtMaybeOpenProof of (unit -> Proof_global.t option) | VtOpenProof of (unit -> Proof_global.t) | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) | VtReadProofOpt of (pstate:Proof_global.t option -> unit) -- cgit v1.2.3 From a7a6fa3219134004f1fc6c757f1c16281724f38f Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 24 May 2019 14:57:33 +0200 Subject: [vernac] more precise types for Add Morph, Instance, and Function --- plugins/funind/indfun.ml | 4 +- plugins/ltac/rewrite.ml | 12 +-- vernac/classes.ml | 235 +++++++++++++++++++++++++++++------------------ vernac/classes.mli | 29 +++++- vernac/comFixpoint.ml | 166 ++++++++++++++++++--------------- vernac/comFixpoint.mli | 18 ++-- vernac/vernacentries.ml | 190 ++++++++++++++++++++++++++------------ 7 files changed, 411 insertions(+), 243 deletions(-) diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index bb6db1f5cf..241da053b7 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -434,7 +434,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp in None, evd,List.rev rev_pconstants | _ -> - let pstate = ComFixpoint.do_fixpoint Global false fixpoint_exprl in + ComFixpoint.do_fixpoint Global false fixpoint_exprl; let evd,rev_pconstants = List.fold_left (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) -> @@ -448,7 +448,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp (Evd.from_env (Global.env ()),[]) fixpoint_exprl in - pstate,evd,List.rev rev_pconstants + None,evd,List.rev rev_pconstants let generate_correction_proof_wf f_ref tcc_lemma_ref diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index c568f63903..caeedadbf4 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1796,11 +1796,11 @@ let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance atts binders (name,t) fields = let program_mode = atts.program in - let _id, proof = Classes.new_instance ~program_mode atts.polymorphic - name binders t (Some (true, CAst.make @@ CRecord (fields))) + let _id = Classes.new_instance ~program_mode atts.polymorphic + name binders t (true, CAst.make @@ CRecord (fields)) ~global:atts.global ~generalize:false Hints.empty_hint_info in - assert (Option.is_empty proof) (* refine:false with term *) + () let declare_instance_refl atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" @@ -2024,12 +2024,12 @@ let add_morphism atts binders m s n = [cHole; s; m]) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - let _, pstate = Classes.new_instance + let _id, pstate = Classes.new_instance_interactive ~program_mode:atts.program ~global:atts.global atts.polymorphic - instance_name binders instance_t None + instance_name binders instance_t ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info in - Option.get pstate (* no instance body -> always open proof *) + pstate (* no instance body -> always open proof *) (** Bind to "rewrite" too *) diff --git a/vernac/classes.ml b/vernac/classes.ml index b9f57c0727..2ef30e770c 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -404,75 +404,18 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps decl ids te | None -> pstate -let do_instance env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = - let props = - match props with - | Some (true, { CAst.v = CRecord fs }) -> - if List.length fs > List.length k.cl_props then - mismatched_props env' (List.map snd fs) k.cl_props; - Some (Inl fs) - | Some (_, t) -> Some (Inr t) - | None -> - if program_mode then Some (Inl []) - else None - in - let subst, sigma = - match props with - | None -> - (if List.is_empty k.cl_props then Some (Inl subst) else None), sigma - | Some (Inr term) -> - let sigma, c = interp_casted_constr_evars ~program_mode env' sigma term cty in - Some (Inr (c, subst)), sigma - | Some (Inl props) -> - let get_id qid = CAst.make ?loc:qid.CAst.loc @@ qualid_basename qid in - let props, rest = - List.fold_left - (fun (props, rest) decl -> - if is_local_assum decl then - try - let is_id (id', _) = match RelDecl.get_name decl, get_id id' with - | Name id, {CAst.v=id'} -> Id.equal id id' - | Anonymous, _ -> false - in - let (loc_mid, c) = List.find is_id rest in - let rest' = List.filter (fun v -> not (is_id v)) rest - in - let {CAst.loc;v=mid} = get_id loc_mid in - List.iter (fun (n, _, x) -> - if Name.equal n (Name mid) then - Option.iter (fun x -> Dumpglob.add_glob ?loc (ConstRef x)) x) k.cl_projs; - c :: props, rest' - with Not_found -> - ((CAst.make @@ CHole (None(* Some Evar_kinds.GoalEvar *), Namegen.IntroAnonymous, None)) :: props), rest - else props, rest) - ([], props) k.cl_props - in - match rest with - | (n, _) :: _ -> - unbound_method env' sigma k.cl_impl (get_id n) - | _ -> - let kcl_props = List.map (Termops.map_rel_decl of_constr) k.cl_props in - let sigma, res = type_ctx_instance ~program_mode (push_rel_context ctx' env') sigma kcl_props props subst in - Some (Inl res), sigma - in - let term, termtype = - match subst with - | None -> let termtype = it_mkProd_or_LetIn cty ctx in - None, termtype - | Some (Inl subst) -> - let subst = List.fold_left2 - (fun subst' s decl -> if is_local_assum decl then s :: subst' else subst') - [] subst (k.cl_props @ snd k.cl_context) - in - let (app, ty_constr) = instance_constructor (k,u) subst in - let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in - let term = it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in - Some term, termtype - | Some (Inr (def, subst)) -> - let termtype = it_mkProd_or_LetIn cty ctx in - let term = it_mkLambda_or_LetIn def ctx in - Some term, termtype +let do_instance_subst_constructor_and_ty subst k u ctx = + let subst = + List.fold_left2 (fun subst' s decl -> + if is_local_assum decl then s :: subst' else subst') + [] subst (k.cl_props @ snd k.cl_context) in + let (app, ty_constr) = instance_constructor (k,u) subst in + let termtype = it_mkProd_or_LetIn ty_constr ctx in + let term = it_mkLambda_or_LetIn (Option.get app) ctx in + term, termtype + +let do_instance_resolve_TC term termtype sigma env = let sigma = Evarutil.nf_evar_map sigma in let sigma = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals_or_obligations ~fail:true env sigma in (* Try resolving fields that are typeclasses automatically. *) @@ -483,24 +426,108 @@ let do_instance env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ct (* Check that the type is free of evars now. *) Pretyping.check_evars env (Evd.from_env env) sigma termtype; let termtype = to_constr sigma termtype in - let pstate = - if not (Evd.has_undefined sigma) && not (Option.is_empty props) then - let term = to_constr sigma (Option.get term) in - (declare_instance_constant pri global imps ?hook id decl poly sigma term termtype; - None) - else if program_mode then - (declare_instance_program env sigma ~global ~poly id pri imps decl term termtype; - None) - else if Option.is_empty props then - let pstate = - Flags.silently (fun () -> - declare_instance_open sigma ?hook ~tac ~global ~poly - id pri imps decl (List.map RelDecl.get_name ctx) term termtype) - () - in - Some pstate - else CErrors.user_err Pp.(str "Unsolved obligations remaining.") in - id, pstate + termtype, sigma + +let do_instance_type_ctx_instance props k env' ctx' sigma ~program_mode subst = + let get_id qid = CAst.make ?loc:qid.CAst.loc @@ qualid_basename qid in + let props, rest = + List.fold_left + (fun (props, rest) decl -> + if is_local_assum decl then + try + let is_id (id', _) = match RelDecl.get_name decl, get_id id' with + | Name id, {CAst.v=id'} -> Id.equal id id' + | Anonymous, _ -> false + in + let (loc_mid, c) = List.find is_id rest in + let rest' = List.filter (fun v -> not (is_id v)) rest + in + let {CAst.loc;v=mid} = get_id loc_mid in + List.iter (fun (n, _, x) -> + if Name.equal n (Name mid) then + Option.iter (fun x -> Dumpglob.add_glob ?loc (ConstRef x)) x) k.cl_projs; + c :: props, rest' + with Not_found -> + ((CAst.make @@ CHole (None(* Some Evar_kinds.GoalEvar *), Namegen.IntroAnonymous, None)) :: props), rest + else props, rest) + ([], props) k.cl_props + in + match rest with + | (n, _) :: _ -> + unbound_method env' sigma k.cl_impl (get_id n) + | _ -> + let kcl_props = List.map (Termops.map_rel_decl of_constr) k.cl_props in + let sigma, res = + type_ctx_instance ~program_mode + (push_rel_context ctx' env') sigma kcl_props props subst in + res, sigma + +let do_instance_interactive env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id = + let term, termtype = + if List.is_empty k.cl_props then + let term, termtype = + do_instance_subst_constructor_and_ty subst k u (ctx' @ ctx) in + Some term, termtype + else + None, it_mkProd_or_LetIn cty ctx in + let termtype, sigma = do_instance_resolve_TC term termtype sigma env in + Flags.silently (fun () -> + declare_instance_open sigma ?hook ~tac ~global ~poly + id pri imps decl (List.map RelDecl.get_name ctx) term termtype) + () + +let do_instance env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = + let term, termtype, sigma = + match props with + | (true, { CAst.v = CRecord fs }) -> + if List.length fs > List.length k.cl_props then + mismatched_props env' (List.map snd fs) k.cl_props; + let subst, sigma = do_instance_type_ctx_instance fs k env' ctx' sigma ~program_mode subst in + let term, termtype = + do_instance_subst_constructor_and_ty subst k u (ctx' @ ctx) in + term, termtype, sigma + | (_, term) -> + let sigma, def = + interp_casted_constr_evars ~program_mode env' sigma term cty in + let termtype = it_mkProd_or_LetIn cty ctx in + let term = it_mkLambda_or_LetIn def ctx in + term, termtype, sigma in + let termtype, sigma = do_instance_resolve_TC (Some term) termtype sigma env in + if Evd.has_undefined sigma then + CErrors.user_err Pp.(str "Unsolved obligations remaining.") + else + let term = to_constr sigma term in + declare_instance_constant pri global imps ?hook id decl poly sigma term termtype + +let do_instance_program env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id opt_props = + let term, termtype, sigma = + match opt_props with + | Some (true, { CAst.v = CRecord fs }) -> + if List.length fs > List.length k.cl_props then + mismatched_props env' (List.map snd fs) k.cl_props; + let subst, sigma = + do_instance_type_ctx_instance fs k env' ctx' sigma ~program_mode subst in + let term, termtype = + do_instance_subst_constructor_and_ty subst k u (ctx' @ ctx) in + Some term, termtype, sigma + | Some (_, term) -> + let sigma, def = + interp_casted_constr_evars ~program_mode env' sigma term cty in + let termtype = it_mkProd_or_LetIn cty ctx in + let term = it_mkLambda_or_LetIn def ctx in + Some term, termtype, sigma + | None -> + let subst, sigma = + do_instance_type_ctx_instance [] k env' ctx' sigma ~program_mode subst in + let term, termtype = + do_instance_subst_constructor_and_ty subst k u (ctx' @ ctx) in + Some term, termtype, sigma in + let termtype, sigma = do_instance_resolve_TC term termtype sigma env in + if not (Evd.has_undefined sigma) && not (Option.is_empty opt_props) then + let term = to_constr sigma (Option.get term) in + declare_instance_constant pri global imps ?hook id decl poly sigma term termtype + else + declare_instance_program env sigma ~global ~poly id pri imps decl term termtype let interp_instance_context ~program_mode env ctx ?(generalize=false) pl tclass = let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in @@ -530,14 +557,12 @@ let interp_instance_context ~program_mode env ctx ?(generalize=false) pl tclass let sigma = resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:true env sigma in sigma, cl, u, c', ctx', ctx, imps, args, decl -let new_instance ?(global=false) ~program_mode - poly instid ctx cl props - ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = - let env = Global.env() in +let new_instance_common ~program_mode ~generalize env instid ctx cl = let ({CAst.loc;v=instid}, pl) = instid in let sigma, k, u, cty, ctx', ctx, imps, subst, decl = interp_instance_context ~program_mode env ~generalize ctx pl cl in + (* The name generator should not be here *) let id = match instid with | Name id -> id @@ -546,8 +571,36 @@ let new_instance ?(global=false) ~program_mode Namegen.next_global_ident_away i (Termops.vars_of_env env) in let env' = push_rel_context ctx env in + id, env', sigma, k, u, cty, ctx', ctx, imps, subst, decl + +let new_instance_interactive ?(global=false) ~program_mode + poly instid ctx cl + ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = + let env = Global.env() in + let id, env', sigma, k, u, cty, ctx', ctx, imps, subst, decl = + new_instance_common ~program_mode ~generalize env instid ctx cl in + id, do_instance_interactive env env' sigma ?hook ~tac ~global ~poly ~program_mode + cty k u ctx ctx' pri decl imps subst id + +let new_instance_program ?(global=false) ~program_mode + poly instid ctx cl opt_props + ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = + let env = Global.env() in + let id, env', sigma, k, u, cty, ctx', ctx, imps, subst, decl = + new_instance_common ~program_mode ~generalize env instid ctx cl in + do_instance_program env env' sigma ?hook ~tac ~global ~poly ~program_mode + cty k u ctx ctx' pri decl imps subst id opt_props; + id + +let new_instance ?(global=false) ~program_mode + poly instid ctx cl props + ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = + let env = Global.env() in + let id, env', sigma, k, u, cty, ctx', ctx, imps, subst, decl = + new_instance_common ~program_mode ~generalize env instid ctx cl in do_instance env env' sigma ?hook ~tac ~global ~poly ~program_mode - cty k u ctx ctx' pri decl imps subst id props + cty k u ctx ctx' pri decl imps subst id props; + id let declare_new_instance ?(global=false) ~program_mode poly instid ctx cl pri = let env = Global.env() in diff --git a/vernac/classes.mli b/vernac/classes.mli index daba78217b..9572cd9598 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -31,7 +31,34 @@ val declare_instance : ?warn:bool -> env -> Evd.evar_map -> val existing_instance : bool -> qualid -> Hints.hint_info_expr option -> unit (** globality, reference, optional priority and pattern information *) +val new_instance_interactive : + ?global:bool (** Not global by default. *) + -> program_mode:bool + -> Decl_kinds.polymorphic + -> name_decl + -> local_binder_expr list + -> constr_expr + -> ?generalize:bool + -> ?tac:unit Proofview.tactic + -> ?hook:(GlobRef.t -> unit) + -> Hints.hint_info_expr + -> Id.t * Proof_global.t + val new_instance : + ?global:bool (** Not global by default. *) + -> program_mode:bool + -> Decl_kinds.polymorphic + -> name_decl + -> local_binder_expr list + -> constr_expr + -> (bool * constr_expr) + -> ?generalize:bool + -> ?tac:unit Proofview.tactic + -> ?hook:(GlobRef.t -> unit) + -> Hints.hint_info_expr + -> Id.t + +val new_instance_program : ?global:bool (** Not global by default. *) -> program_mode:bool -> Decl_kinds.polymorphic @@ -43,7 +70,7 @@ val new_instance : -> ?tac:unit Proofview.tactic -> ?hook:(GlobRef.t -> unit) -> Hints.hint_info_expr - -> Id.t * Proof_global.t option (* May open a proof *) + -> Id.t val declare_new_instance : ?global:bool (** Not global by default. *) diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 006ac314a5..7a4e6d8698 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -255,79 +255,78 @@ let interp_fixpoint ~cofix l ntns = let uctx,fix = ground_fixpoint env evd fix in (fix,pl,uctx,info) +let declare_fixpoint_notations ntns = + List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns + +let declare_fixpoint_interactive local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = + (* Some bodies to define by proof *) + let thms = + List.map3 (fun id t (ctx,imps,_) -> (id,(EConstr.of_constr t,(List.map RelDecl.get_name ctx,imps)))) + fixnames fixtypes fiximps in + let init_tac = + Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) + fixdefs) in + let evd = Evd.from_ctx ctx in + let pstate = Lemmas.start_proof_with_initialization (local,poly,DefinitionBody Fixpoint) + evd pl (Some(false,indexes,init_tac)) thms None in + declare_fixpoint_notations ntns; + pstate + let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = - let pstate = - if List.exists Option.is_empty fixdefs then - (* Some bodies to define by proof *) - let thms = - List.map3 (fun id t (ctx,imps,_) -> (id,(EConstr.of_constr t,(List.map RelDecl.get_name ctx,imps)))) - fixnames fixtypes fiximps in - let init_tac = - Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) - fixdefs) in - let evd = Evd.from_ctx ctx in - Some - (Lemmas.start_proof_with_initialization (local,poly,DefinitionBody Fixpoint) - evd pl (Some(false,indexes,init_tac)) thms None) - else begin - (* We shortcut the proof process *) - let fixdefs = List.map Option.get fixdefs in - let fixdecls = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in - let env = Global.env() in - let indexes = search_guard env indexes fixdecls in - let fiximps = List.map (fun (n,r,p) -> r) fiximps in - let vars = Vars.universes_of_constr (mkFix ((indexes,0),fixdecls)) in - let fixdecls = - List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in - let evd = Evd.from_ctx ctx in - let evd = Evd.restrict_universe_context evd vars in - let ctx = Evd.check_univ_decl ~poly evd pl in - let pl = Evd.universe_binders evd in - let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in - ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) - fixnames fixdecls fixtypes fiximps); - (* Declare the recursive definitions *) - fixpoint_message (Some indexes) fixnames; - None - end in - (* Declare notations *) - List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; + (* We shortcut the proof process *) + let fixdefs = List.map Option.get fixdefs in + let fixdecls = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in + let env = Global.env() in + let indexes = search_guard env indexes fixdecls in + let fiximps = List.map (fun (n,r,p) -> r) fiximps in + let vars = Vars.universes_of_constr (mkFix ((indexes,0),fixdecls)) in + let fixdecls = + List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in + let evd = Evd.from_ctx ctx in + let evd = Evd.restrict_universe_context evd vars in + let ctx = Evd.check_univ_decl ~poly evd pl in + let pl = Evd.universe_binders evd in + let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in + ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) + fixnames fixdecls fixtypes fiximps); + (* Declare the recursive definitions *) + fixpoint_message (Some indexes) fixnames; + declare_fixpoint_notations ntns + +let declare_cofixpoint_notations = declare_fixpoint_notations + +let declare_cofixpoint_interactive local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = + (* Some bodies to define by proof *) + let thms = + List.map3 (fun id t (ctx,imps,_) -> (id,(EConstr.of_constr t,(List.map RelDecl.get_name ctx,imps)))) + fixnames fixtypes fiximps in + let init_tac = + Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) + fixdefs) in + let evd = Evd.from_ctx ctx in + let pstate = Lemmas.start_proof_with_initialization + (Global,poly, DefinitionBody CoFixpoint) + evd pl (Some(true,[],init_tac)) thms None in + declare_cofixpoint_notations ntns; pstate let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = - let pstate = - if List.exists Option.is_empty fixdefs then - (* Some bodies to define by proof *) - let thms = - List.map3 (fun id t (ctx,imps,_) -> (id,(EConstr.of_constr t,(List.map RelDecl.get_name ctx,imps)))) - fixnames fixtypes fiximps in - let init_tac = - Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) - fixdefs) in - let evd = Evd.from_ctx ctx in - Some (Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) - evd pl (Some(true,[],init_tac)) thms None) - else begin - (* We shortcut the proof process *) - let fixdefs = List.map Option.get fixdefs in - let fixdecls = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in - let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in - let vars = Vars.universes_of_constr (List.hd fixdecls) in - let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in - let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in - let evd = Evd.from_ctx ctx in - let evd = Evd.restrict_universe_context evd vars in - let ctx = Evd.check_univ_decl ~poly evd pl in - let pl = Evd.universe_binders evd in - ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) - fixnames fixdecls fixtypes fiximps); - (* Declare the recursive definitions *) - cofixpoint_message fixnames; - None - end in - (* Declare notations *) - List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; - pstate + (* We shortcut the proof process *) + let fixdefs = List.map Option.get fixdefs in + let fixdecls = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in + let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in + let vars = Vars.universes_of_constr (List.hd fixdecls) in + let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in + let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in + let evd = Evd.from_ctx ctx in + let evd = Evd.restrict_universe_context evd vars in + let ctx = Evd.check_univ_decl ~poly evd pl in + let pl = Evd.universe_binders evd in + ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) + fixnames fixdecls fixtypes fiximps); + (* Declare the recursive definitions *) + cofixpoint_message fixnames; + declare_cofixpoint_notations ntns let extract_decreasing_argument ~structonly = function { CAst.v = v } -> match v with | CStructRec na -> na @@ -366,18 +365,33 @@ let check_safe () = let flags = Environ.typing_flags (Global.env ()) in flags.check_universes && flags.check_guarded -let do_fixpoint local poly l = +let do_fixpoint_common l = let fixl, ntns = extract_fixpoint_components ~structonly:true l in let (_, _, _, info as fix) = interp_fixpoint ~cofix:false fixl ntns in - let possible_indexes = - List.map compute_possible_guardness_evidences info in - let pstate = declare_fixpoint local poly fix possible_indexes ntns in + fixl, ntns, fix, List.map compute_possible_guardness_evidences info + +let do_fixpoint_interactive local poly l = + let fixl, ntns, fix, possible_indexes = do_fixpoint_common l in + let pstate = declare_fixpoint_interactive local poly fix possible_indexes ntns in if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else (); pstate -let do_cofixpoint local poly l = +let do_fixpoint local poly l = + let fixl, ntns, fix, possible_indexes = do_fixpoint_common l in + declare_fixpoint local poly fix possible_indexes ntns; + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + +let do_cofixpoint_common l = let fixl,ntns = extract_cofixpoint_components l in - let cofix = interp_fixpoint ~cofix:true fixl ntns in - let pstate = declare_cofixpoint local poly cofix ntns in + ntns, interp_fixpoint ~cofix:true fixl ntns + +let do_cofixpoint_interactive local poly l = + let ntns, cofix = do_cofixpoint_common l in + let pstate = declare_cofixpoint_interactive local poly cofix ntns in if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else (); pstate + +let do_cofixpoint local poly l = + let ntns, cofix = do_cofixpoint_common l in + declare_cofixpoint local poly cofix ntns; + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index 9e376c8f96..b32ea44da2 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -18,13 +18,21 @@ open Vernacexpr (** Entry points for the vernacular commands Fixpoint and CoFixpoint *) +val do_fixpoint_interactive : + (* When [false], assume guarded. *) + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> Proof_global.t + val do_fixpoint : (* When [false], assume guarded. *) - locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> Proof_global.t option + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit + +val do_cofixpoint_interactive : + (* When [false], assume guarded. *) + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> Proof_global.t val do_cofixpoint : (* When [false], assume guarded. *) - locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> Proof_global.t option + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit (************************************************************************) (** Internal API *) @@ -84,15 +92,13 @@ val declare_fixpoint : locality -> polymorphic -> recursive_preentry * UState.universe_decl * UState.t * (Constr.rel_context * Impargs.manual_implicits * int option) list -> - Proof_global.lemma_possible_guards -> decl_notation list -> - Proof_global.t option + Proof_global.lemma_possible_guards -> decl_notation list -> unit val declare_cofixpoint : locality -> polymorphic -> recursive_preentry * UState.universe_decl * UState.t * (Constr.rel_context * Impargs.manual_implicits * int option) list -> - decl_notation list -> - Proof_global.t option + decl_notation list -> unit (** Very private function, do not use *) val compute_possible_guardness_evidences : diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index da9fa35202..9859bb62f0 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -581,47 +581,48 @@ let vernac_definition_hook p = function Some (Class.add_subclass_hook p) | _ -> None -let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def ~pstate = +let vernac_definition_name lid local ~pstate = + let lid = + match lid with + | { v = Name.Anonymous; loc } -> CAst.make ?loc (fresh_name_for_anonymous_theorem ~pstate) + | { v = Name.Name n; loc } -> CAst.make ?loc n in + let () = + match local with + | Discharge -> Dumpglob.dump_definition lid true "var" + | Local | Global -> Dumpglob.dump_definition lid false "def" + in + lid + +let vernac_definition_interactive ~atts (discharge, kind) (lid, pl) bl t ~pstate = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in let hook = vernac_definition_hook atts.polymorphic kind in - let () = - match id with - | Anonymous -> () - | Name n -> let lid = CAst.make ?loc n in - match local with - | Discharge -> Dumpglob.dump_definition lid true "var" - | Local | Global -> Dumpglob.dump_definition lid false "def" - in let program_mode = atts.program in - let name = - match id with - | Anonymous -> fresh_name_for_anonymous_theorem ~pstate - | Name n -> n - in - (match def with - | ProveBody (bl,t) -> (* local binders, typ *) - Some (start_proof_and_print ~program_mode (local, atts.polymorphic, DefinitionBody kind) - ?hook [(CAst.make ?loc name, pl), (bl, t)]) - | DefineBody (bl,red_option,c,typ_opt) -> - let pstate = Option.map Proof_global.get_current_pstate pstate in - let red_option = match red_option with - | None -> None - | Some r -> - let sigma, env = get_current_or_global_context ~pstate in - Some (snd (Hook.get f_interp_redexp env sigma r)) in - ComDefinition.do_definition ~program_mode name - (local, atts.polymorphic, kind) pl bl red_option c typ_opt ?hook; - None - ) + let name = vernac_definition_name lid local ~pstate in + start_proof_and_print ~program_mode (local, atts.polymorphic, DefinitionBody kind) ?hook [(name, pl), (bl, t)] + +let vernac_definition ~atts (discharge, kind) (lid, pl) bl red_option c typ_opt ~pstate = + let open DefAttributes in + let local = enforce_locality_exp atts.locality discharge in + let hook = vernac_definition_hook atts.polymorphic kind in + let program_mode = atts.program in + let name = vernac_definition_name lid local ~pstate in + let pstate = Option.map Proof_global.get_current_pstate pstate in + let red_option = match red_option with + | None -> None + | Some r -> + let sigma, env = get_current_or_global_context ~pstate in + Some (snd (Hook.get f_interp_redexp env sigma r)) in + ComDefinition.do_definition ~program_mode name.v + (local, atts.polymorphic, kind) pl bl red_option c typ_opt ?hook (* NB: pstate argument to use combinators easily *) -let vernac_start_proof ~atts kind l ~pstate = +let vernac_start_proof ~atts kind l = let open DefAttributes in let local = enforce_locality_exp atts.locality NoDischarge in if Dumpglob.dump () then List.iter (fun ((id, _), _) -> Dumpglob.dump_definition id false "prf") l; - Some (start_proof_and_print ~program_mode:atts.program (local, atts.polymorphic, Proof kind) l) + start_proof_and_print ~program_mode:atts.program (local, atts.polymorphic, Proof kind) l let vernac_end_proof ?pstate:ontop ?proof = function | Admitted -> @@ -814,30 +815,46 @@ let vernac_inductive ~atts cum lo finite indl = in vernac_record cum (Class true) atts.polymorphic finite [id, bl, c, None, [f]] *) -let vernac_fixpoint ~atts discharge l ~pstate = - let open DefAttributes in - let local = enforce_locality_exp atts.locality discharge in +let vernac_fixpoint_common ~atts discharge l = if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; - (* XXX: Switch to the attribute system and match on ~atts *) - let do_fixpoint = if atts.program then - fun local sign l -> ComProgramFixpoint.do_fixpoint local sign l; None - else - ComFixpoint.do_fixpoint - in - do_fixpoint local atts.polymorphic l + enforce_locality_exp atts.DefAttributes.locality discharge -let vernac_cofixpoint ~atts discharge l ~pstate = +let vernac_fixpoint_interactive ~atts discharge l = let open DefAttributes in - let local = enforce_locality_exp atts.locality discharge in + let local = vernac_fixpoint_common ~atts discharge l in + if atts.program then + CErrors.user_err Pp.(str"Program Fixpoint requires a body"); + ComFixpoint.do_fixpoint_interactive local atts.polymorphic l + +let vernac_fixpoint ~atts discharge l = + let open DefAttributes in + let local = vernac_fixpoint_common ~atts discharge l in + if atts.program then + (* XXX: Switch to the attribute system and match on ~atts *) + ComProgramFixpoint.do_fixpoint local atts.polymorphic l + else + ComFixpoint.do_fixpoint local atts.polymorphic l + +let vernac_cofixpoint_common ~atts discharge l = if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; - let do_cofixpoint = if atts.program then - fun local sign l -> ComProgramFixpoint.do_cofixpoint local sign l; None - else - ComFixpoint.do_cofixpoint - in - do_cofixpoint local atts.polymorphic l + enforce_locality_exp atts.DefAttributes.locality discharge + +let vernac_cofixpoint_interactive ~atts discharge l = + let open DefAttributes in + let local = vernac_cofixpoint_common ~atts discharge l in + if atts.program then + CErrors.user_err Pp.(str"Program CoFixpoint requires a body"); + ComFixpoint.do_cofixpoint_interactive local atts.polymorphic l + +let vernac_cofixpoint ~atts discharge l = + let open DefAttributes in + let local = vernac_cofixpoint_common ~atts discharge l in + if atts.program then + ComProgramFixpoint.do_cofixpoint local atts.polymorphic l + else + ComFixpoint.do_cofixpoint local atts.polymorphic l let vernac_scheme l = if Dumpglob.dump () then @@ -1068,12 +1085,35 @@ let vernac_identity_coercion ~atts id qids qidt = (* Type classes *) -let vernac_instance ~atts name bl t props pri = +let vernac_instance_common ~atts name = let open DefAttributes in let global = not (make_section_locality atts.locality) in Dumpglob.dump_constraint (fst name) false "inst"; let program_mode = atts.program in - Classes.new_instance ~program_mode ~global atts.polymorphic name bl t props pri + program_mode, global + +let vernac_instance_interactive ~atts name bl t pri = + let open DefAttributes in + let program_mode, global = vernac_instance_common ~atts name in + let _id, pstate = + Classes.new_instance_interactive + ~program_mode ~global atts.polymorphic name bl t pri in + pstate + +let vernac_instance_program ~atts name bl t opt_props pri = + let open DefAttributes in + let program_mode, global = vernac_instance_common ~atts name in + let _id = Classes.new_instance_program + ~program_mode ~global atts.polymorphic name bl t opt_props pri in + () + +let vernac_instance ~atts name bl t props pri = + let open DefAttributes in + let program_mode, global = vernac_instance_common ~atts name in + let _id = + Classes.new_instance + ~program_mode ~global atts.polymorphic name bl t props pri in + () let vernac_declare_instance ~atts id bl inst pri = let open DefAttributes in @@ -2237,9 +2277,15 @@ let with_def_attributes ~atts f = if atts.DefAttributes.program then Obligations.check_program_libraries (); f ~atts -let with_maybe_open_proof ~pstate f = - let opt = f ~pstate in - Proof_global.maybe_push ~ontop:pstate opt +let with_read_proof ~pstate f = + f ~pstate; + pstate + +let with_open_proof ~pstate f = + Some (Proof_global.push ~ontop:pstate (f ~pstate)) + +let with_open_proof_simple ~pstate f = + Some (Proof_global.push ~ontop:pstate f) (** A global default timeout, controlled by option "Set Default Timeout n". Use "Unset Default Timeout" to deactivate it (or set it to 0). *) @@ -2376,10 +2422,12 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.stack option = pstate (* Gallina *) - | VernacDefinition ((discharge,kind),lid,d) -> - with_maybe_open_proof ~pstate (with_def_attributes ~atts vernac_definition discharge kind lid d) + | VernacDefinition (dk,lid,ProveBody(bl,t)) -> + with_open_proof ~pstate (with_def_attributes ~atts vernac_definition_interactive dk lid bl t) + | VernacDefinition (dk,lid,DefineBody(bl,red_option,c,typ_opt)) -> + with_read_proof ~pstate (with_def_attributes ~atts vernac_definition dk lid bl red_option c typ_opt) | VernacStartTheoremProof (k,l) -> - with_maybe_open_proof ~pstate (with_def_attributes ~atts vernac_start_proof k l) + with_open_proof_simple ~pstate (with_def_attributes ~atts vernac_start_proof k l) | VernacEndProof e -> unsupported_attributes atts; vernac_end_proof ?proof ?pstate e @@ -2393,9 +2441,17 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.stack option = vernac_inductive ~atts cum priv finite l; pstate | VernacFixpoint (discharge, l) -> - with_maybe_open_proof ~pstate (with_def_attributes ~atts vernac_fixpoint discharge l) + let opens = List.exists (fun ((_,_,_,_,p),_) -> Option.is_empty p) l in + if opens then + with_open_proof_simple ~pstate (with_def_attributes ~atts vernac_fixpoint_interactive discharge l) + else + (with_def_attributes ~atts vernac_fixpoint discharge l; pstate) | VernacCoFixpoint (discharge, l) -> - with_maybe_open_proof ~pstate (with_def_attributes ~atts vernac_cofixpoint discharge l) + let opens = List.exists (fun ((_,_,_,p),_) -> Option.is_empty p) l in + if opens then + with_open_proof_simple ~pstate (with_def_attributes ~atts vernac_cofixpoint_interactive discharge l) + else + (with_def_attributes ~atts vernac_cofixpoint discharge l; pstate) | VernacScheme l -> unsupported_attributes atts; vernac_scheme l; @@ -2465,8 +2521,20 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.stack option = (* Type classes *) | VernacInstance (name, bl, t, props, info) -> - with_maybe_open_proof ~pstate (fun ~pstate:_ -> - snd @@ with_def_attributes ~atts (vernac_instance name bl t props info)) + if (DefAttributes.parse atts).DefAttributes.program then begin + with_def_attributes ~atts + (vernac_instance_program name bl t props info); + pstate + end else begin + match props with + | None -> + with_open_proof_simple ~pstate + (with_def_attributes ~atts + (vernac_instance_interactive name bl t info)) + | Some props -> + with_def_attributes ~atts (vernac_instance name bl t props info); + pstate + end | VernacDeclareInstance (id, bl, inst, info) -> with_def_attributes ~atts vernac_declare_instance id bl inst info; pstate -- cgit v1.2.3 From 06df92fffc05d501fefdcf949625a33bd52f1980 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 27 May 2019 15:53:50 +0200 Subject: [classes] remove program mode from the new_instance_* APIs --- plugins/ltac/rewrite.ml | 5 ++--- vernac/classes.ml | 34 +++++++++++++++++----------------- vernac/classes.mli | 3 --- vernac/vernacentries.ml | 24 ++++++++++-------------- 4 files changed, 29 insertions(+), 37 deletions(-) diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index caeedadbf4..792cd5f9ef 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1795,8 +1795,7 @@ let declare_an_instance n s args = let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance atts binders (name,t) fields = - let program_mode = atts.program in - let _id = Classes.new_instance ~program_mode atts.polymorphic + let _id = Classes.new_instance atts.polymorphic name binders t (true, CAst.make @@ CRecord (fields)) ~global:atts.global ~generalize:false Hints.empty_hint_info in @@ -2025,7 +2024,7 @@ let add_morphism atts binders m s n = in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in let _id, pstate = Classes.new_instance_interactive - ~program_mode:atts.program ~global:atts.global atts.polymorphic + ~global:atts.global atts.polymorphic instance_name binders instance_t ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info in diff --git a/vernac/classes.ml b/vernac/classes.ml index 2ef30e770c..763876b5c0 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -462,7 +462,7 @@ let do_instance_type_ctx_instance props k env' ctx' sigma ~program_mode subst = (push_rel_context ctx' env') sigma kcl_props props subst in res, sigma -let do_instance_interactive env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id = +let do_instance_interactive env env' sigma ?hook ~tac ~global ~poly cty k u ctx ctx' pri decl imps subst id = let term, termtype = if List.is_empty k.cl_props then let term, termtype = @@ -476,19 +476,19 @@ let do_instance_interactive env env' sigma ?hook ~tac ~global ~poly ~program_mod id pri imps decl (List.map RelDecl.get_name ctx) term termtype) () -let do_instance env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = +let do_instance env env' sigma ?hook ~tac ~global ~poly cty k u ctx ctx' pri decl imps subst id props = let term, termtype, sigma = match props with | (true, { CAst.v = CRecord fs }) -> if List.length fs > List.length k.cl_props then mismatched_props env' (List.map snd fs) k.cl_props; - let subst, sigma = do_instance_type_ctx_instance fs k env' ctx' sigma ~program_mode subst in + let subst, sigma = do_instance_type_ctx_instance fs k env' ctx' sigma ~program_mode:false subst in let term, termtype = do_instance_subst_constructor_and_ty subst k u (ctx' @ ctx) in term, termtype, sigma | (_, term) -> let sigma, def = - interp_casted_constr_evars ~program_mode env' sigma term cty in + interp_casted_constr_evars ~program_mode:false env' sigma term cty in let termtype = it_mkProd_or_LetIn cty ctx in let term = it_mkLambda_or_LetIn def ctx in term, termtype, sigma in @@ -499,26 +499,26 @@ let do_instance env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ct let term = to_constr sigma term in declare_instance_constant pri global imps ?hook id decl poly sigma term termtype -let do_instance_program env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id opt_props = +let do_instance_program env env' sigma ?hook ~tac ~global ~poly cty k u ctx ctx' pri decl imps subst id opt_props = let term, termtype, sigma = match opt_props with | Some (true, { CAst.v = CRecord fs }) -> if List.length fs > List.length k.cl_props then mismatched_props env' (List.map snd fs) k.cl_props; let subst, sigma = - do_instance_type_ctx_instance fs k env' ctx' sigma ~program_mode subst in + do_instance_type_ctx_instance fs k env' ctx' sigma ~program_mode:true subst in let term, termtype = do_instance_subst_constructor_and_ty subst k u (ctx' @ ctx) in Some term, termtype, sigma | Some (_, term) -> let sigma, def = - interp_casted_constr_evars ~program_mode env' sigma term cty in + interp_casted_constr_evars ~program_mode:true env' sigma term cty in let termtype = it_mkProd_or_LetIn cty ctx in let term = it_mkLambda_or_LetIn def ctx in Some term, termtype, sigma | None -> let subst, sigma = - do_instance_type_ctx_instance [] k env' ctx' sigma ~program_mode subst in + do_instance_type_ctx_instance [] k env' ctx' sigma ~program_mode:true subst in let term, termtype = do_instance_subst_constructor_and_ty subst k u (ctx' @ ctx) in Some term, termtype, sigma in @@ -573,32 +573,32 @@ let new_instance_common ~program_mode ~generalize env instid ctx cl = let env' = push_rel_context ctx env in id, env', sigma, k, u, cty, ctx', ctx, imps, subst, decl -let new_instance_interactive ?(global=false) ~program_mode +let new_instance_interactive ?(global=false) poly instid ctx cl ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in let id, env', sigma, k, u, cty, ctx', ctx, imps, subst, decl = - new_instance_common ~program_mode ~generalize env instid ctx cl in - id, do_instance_interactive env env' sigma ?hook ~tac ~global ~poly ~program_mode + new_instance_common ~program_mode:false ~generalize env instid ctx cl in + id, do_instance_interactive env env' sigma ?hook ~tac ~global ~poly cty k u ctx ctx' pri decl imps subst id -let new_instance_program ?(global=false) ~program_mode +let new_instance_program ?(global=false) poly instid ctx cl opt_props ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in let id, env', sigma, k, u, cty, ctx', ctx, imps, subst, decl = - new_instance_common ~program_mode ~generalize env instid ctx cl in - do_instance_program env env' sigma ?hook ~tac ~global ~poly ~program_mode + new_instance_common ~program_mode:true ~generalize env instid ctx cl in + do_instance_program env env' sigma ?hook ~tac ~global ~poly cty k u ctx ctx' pri decl imps subst id opt_props; id -let new_instance ?(global=false) ~program_mode +let new_instance ?(global=false) poly instid ctx cl props ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in let id, env', sigma, k, u, cty, ctx', ctx, imps, subst, decl = - new_instance_common ~program_mode ~generalize env instid ctx cl in - do_instance env env' sigma ?hook ~tac ~global ~poly ~program_mode + new_instance_common ~program_mode:false ~generalize env instid ctx cl in + do_instance env env' sigma ?hook ~tac ~global ~poly cty k u ctx ctx' pri decl imps subst id props; id diff --git a/vernac/classes.mli b/vernac/classes.mli index 9572cd9598..3ec4325848 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -33,7 +33,6 @@ val existing_instance : bool -> qualid -> Hints.hint_info_expr option -> unit val new_instance_interactive : ?global:bool (** Not global by default. *) - -> program_mode:bool -> Decl_kinds.polymorphic -> name_decl -> local_binder_expr list @@ -46,7 +45,6 @@ val new_instance_interactive : val new_instance : ?global:bool (** Not global by default. *) - -> program_mode:bool -> Decl_kinds.polymorphic -> name_decl -> local_binder_expr list @@ -60,7 +58,6 @@ val new_instance : val new_instance_program : ?global:bool (** Not global by default. *) - -> program_mode:bool -> Decl_kinds.polymorphic -> name_decl -> local_binder_expr list diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 9859bb62f0..2165f7c3ef 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -1085,40 +1085,36 @@ let vernac_identity_coercion ~atts id qids qidt = (* Type classes *) -let vernac_instance_common ~atts name = - let open DefAttributes in - let global = not (make_section_locality atts.locality) in - Dumpglob.dump_constraint (fst name) false "inst"; - let program_mode = atts.program in - program_mode, global - let vernac_instance_interactive ~atts name bl t pri = let open DefAttributes in - let program_mode, global = vernac_instance_common ~atts name in + Dumpglob.dump_constraint (fst name) false "inst"; + let global = not (make_section_locality atts.locality) in let _id, pstate = Classes.new_instance_interactive - ~program_mode ~global atts.polymorphic name bl t pri in + ~global atts.polymorphic name bl t pri in pstate let vernac_instance_program ~atts name bl t opt_props pri = let open DefAttributes in - let program_mode, global = vernac_instance_common ~atts name in + Dumpglob.dump_constraint (fst name) false "inst"; + let global = not (make_section_locality atts.locality) in let _id = Classes.new_instance_program - ~program_mode ~global atts.polymorphic name bl t opt_props pri in + ~global atts.polymorphic name bl t opt_props pri in () let vernac_instance ~atts name bl t props pri = let open DefAttributes in - let program_mode, global = vernac_instance_common ~atts name in + Dumpglob.dump_constraint (fst name) false "inst"; + let global = not (make_section_locality atts.locality) in let _id = Classes.new_instance - ~program_mode ~global atts.polymorphic name bl t props pri in + ~global atts.polymorphic name bl t props pri in () let vernac_declare_instance ~atts id bl inst pri = let open DefAttributes in - let global = not (make_section_locality atts.locality) in Dumpglob.dump_definition (fst id) false "inst"; + let global = not (make_section_locality atts.locality) in Classes.declare_new_instance ~program_mode:atts.program ~global atts.polymorphic id bl inst pri let vernac_context ~poly l = -- cgit v1.2.3 From 13915784a568f9e0c8a15c99a516a898726dbc61 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 27 May 2019 16:40:52 +0200 Subject: update overlays --- .../user-overlays/10050-SkySkimmer-pass-less-ontop.sh | 18 ------------------ dev/ci/user-overlays/10215-gares-less-ontop.sh | 15 +++++++++++++++ 2 files changed, 15 insertions(+), 18 deletions(-) delete mode 100644 dev/ci/user-overlays/10050-SkySkimmer-pass-less-ontop.sh create mode 100644 dev/ci/user-overlays/10215-gares-less-ontop.sh diff --git a/dev/ci/user-overlays/10050-SkySkimmer-pass-less-ontop.sh b/dev/ci/user-overlays/10050-SkySkimmer-pass-less-ontop.sh deleted file mode 100644 index 0c3f1eefed..0000000000 --- a/dev/ci/user-overlays/10050-SkySkimmer-pass-less-ontop.sh +++ /dev/null @@ -1,18 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10050" ] || [ "$CI_BRANCH" = "pass-less-ontop" ]; then - - elpi_CI_REF=pass-less-ontop - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi - - equations_CI_REF=pass-less-ontop - equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - - mtac2_CI_REF=pass-less-ontop - mtac2_CI_GITURL=https://github.com/SkySkimmer/Mtac2 - - paramcoq_CI_REF=pass-less-ontop - paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq - - quickchick_CI_REF=pass-less-ontop - quickchick_CI_GITURL=https://github.com/SkySkimmer/QuickChick - -fi diff --git a/dev/ci/user-overlays/10215-gares-less-ontop.sh b/dev/ci/user-overlays/10215-gares-less-ontop.sh new file mode 100644 index 0000000000..bceb5ad0e8 --- /dev/null +++ b/dev/ci/user-overlays/10215-gares-less-ontop.sh @@ -0,0 +1,15 @@ +if [ "$CI_PULL_REQUEST" = "10215" ] || [ "$CI_BRANCH" = "custom-typing" ]; then + + equations_CI_REF=pass-less-ontop + equations_CI_GITURL=https://github.com/gares/Coq-Equations + + mtac2_CI_REF=pass-less-ontop + mtac2_CI_GITURL=https://github.com/SkySkimmer/Mtac2 + + paramcoq_CI_REF=pass-less-ontop + paramcoq_CI_GITURL=https://github.com/gares/paramcoq + + quickchick_CI_REF=pass-less-ontop + quickchick_CI_GITURL=https://github.com/gares/QuickChick + +fi -- cgit v1.2.3 From cc40f32473abf33edd98b95b017a89d930190f7a Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 27 May 2019 16:41:54 +0200 Subject: remove leftover comments --- vernac/comFixpoint.mli | 4 ---- 1 file changed, 4 deletions(-) diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index b32ea44da2..c8d617da5f 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -19,19 +19,15 @@ open Vernacexpr (** Entry points for the vernacular commands Fixpoint and CoFixpoint *) val do_fixpoint_interactive : - (* When [false], assume guarded. *) locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> Proof_global.t val do_fixpoint : - (* When [false], assume guarded. *) locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit val do_cofixpoint_interactive : - (* When [false], assume guarded. *) locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> Proof_global.t val do_cofixpoint : - (* When [false], assume guarded. *) locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit (************************************************************************) -- cgit v1.2.3 From cfbfce0639a4e608210b21227f923a4f27ab6752 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 27 May 2019 17:11:53 +0200 Subject: [rewrite] remove program_mode from attributes (unused) --- plugins/ltac/rewrite.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 792cd5f9ef..7b286e69dc 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -42,13 +42,13 @@ module NamedDecl = Context.Named.Declaration (** Typeclass-based generalized rewriting. *) -type rewrite_attributes = { polymorphic : bool; program : bool; global : bool } +type rewrite_attributes = { polymorphic : bool; global : bool } let rewrite_attributes = let open Attributes.Notations in Attributes.(polymorphic ++ program ++ locality) >>= fun ((polymorphic, program), locality) -> let global = not (Locality.make_section_locality locality) in - Attributes.Notations.return { polymorphic; program; global } + Attributes.Notations.return { polymorphic; global } (** Constants used by the tactic. *) -- cgit v1.2.3 From 9bc58fc7038d627b06c176854811d1947bca09f2 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Tue, 28 May 2019 13:58:56 +0200 Subject: Simplify vernacentries calls to classes, remove unused args, reject deprecated attribute This code was significantly more complex than necessary. --- vernac/classes.ml | 24 ++++----- vernac/classes.mli | 2 - vernac/vernacentries.ml | 126 +++++++++++++++++++++--------------------------- 3 files changed, 66 insertions(+), 86 deletions(-) diff --git a/vernac/classes.ml b/vernac/classes.ml index 763876b5c0..9cc8467c57 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -333,7 +333,7 @@ let declare_instance_constant info global imps ?hook id decl poly sigma term ter Declare.declare_univ_binders (ConstRef kn) (Evd.universe_binders sigma); instance_hook info global imps ?hook (ConstRef kn) -let do_declare_instance env sigma ~global ~poly k u ctx ctx' pri decl imps subst id = +let do_declare_instance sigma ~global ~poly k u ctx ctx' pri decl imps subst id = let subst = List.fold_left2 (fun subst' s decl -> if is_local_assum decl then s :: subst' else subst') [] subst (snd k.cl_context) @@ -462,7 +462,7 @@ let do_instance_type_ctx_instance props k env' ctx' sigma ~program_mode subst = (push_rel_context ctx' env') sigma kcl_props props subst in res, sigma -let do_instance_interactive env env' sigma ?hook ~tac ~global ~poly cty k u ctx ctx' pri decl imps subst id = +let do_instance_interactive env sigma ?hook ~tac ~global ~poly cty k u ctx ctx' pri decl imps subst id = let term, termtype = if List.is_empty k.cl_props then let term, termtype = @@ -476,7 +476,7 @@ let do_instance_interactive env env' sigma ?hook ~tac ~global ~poly cty k u ctx id pri imps decl (List.map RelDecl.get_name ctx) term termtype) () -let do_instance env env' sigma ?hook ~tac ~global ~poly cty k u ctx ctx' pri decl imps subst id props = +let do_instance env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri decl imps subst id props = let term, termtype, sigma = match props with | (true, { CAst.v = CRecord fs }) -> @@ -499,7 +499,7 @@ let do_instance env env' sigma ?hook ~tac ~global ~poly cty k u ctx ctx' pri dec let term = to_constr sigma term in declare_instance_constant pri global imps ?hook id decl poly sigma term termtype -let do_instance_program env env' sigma ?hook ~tac ~global ~poly cty k u ctx ctx' pri decl imps subst id opt_props = +let do_instance_program env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri decl imps subst id opt_props = let term, termtype, sigma = match opt_props with | Some (true, { CAst.v = CRecord fs }) -> @@ -529,7 +529,7 @@ let do_instance_program env env' sigma ?hook ~tac ~global ~poly cty k u ctx ctx' else declare_instance_program env sigma ~global ~poly id pri imps decl term termtype -let interp_instance_context ~program_mode env ctx ?(generalize=false) pl tclass = +let interp_instance_context ~program_mode env ctx ~generalize pl tclass = let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in let tclass = if generalize then CAst.make @@ CGeneralization (Implicit, Some AbsPi, tclass) @@ -579,26 +579,26 @@ let new_instance_interactive ?(global=false) let env = Global.env() in let id, env', sigma, k, u, cty, ctx', ctx, imps, subst, decl = new_instance_common ~program_mode:false ~generalize env instid ctx cl in - id, do_instance_interactive env env' sigma ?hook ~tac ~global ~poly + id, do_instance_interactive env sigma ?hook ~tac ~global ~poly cty k u ctx ctx' pri decl imps subst id let new_instance_program ?(global=false) poly instid ctx cl opt_props - ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = + ?(generalize=true) ?hook pri = let env = Global.env() in let id, env', sigma, k, u, cty, ctx', ctx, imps, subst, decl = new_instance_common ~program_mode:true ~generalize env instid ctx cl in - do_instance_program env env' sigma ?hook ~tac ~global ~poly + do_instance_program env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri decl imps subst id opt_props; id let new_instance ?(global=false) poly instid ctx cl props - ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = + ?(generalize=true) ?hook pri = let env = Global.env() in let id, env', sigma, k, u, cty, ctx', ctx, imps, subst, decl = new_instance_common ~program_mode:false ~generalize env instid ctx cl in - do_instance env env' sigma ?hook ~tac ~global ~poly + do_instance env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri decl imps subst id props; id @@ -606,6 +606,6 @@ let declare_new_instance ?(global=false) ~program_mode poly instid ctx cl pri = let env = Global.env() in let ({CAst.loc;v=instid}, pl) = instid in let sigma, k, u, cty, ctx', ctx, imps, subst, decl = - interp_instance_context ~program_mode env ctx pl cl + interp_instance_context ~program_mode ~generalize:false env ctx pl cl in - do_declare_instance env sigma ~global ~poly k u ctx ctx' pri decl imps subst instid + do_declare_instance sigma ~global ~poly k u ctx ctx' pri decl imps subst instid diff --git a/vernac/classes.mli b/vernac/classes.mli index 3ec4325848..e61935c87a 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -51,7 +51,6 @@ val new_instance : -> constr_expr -> (bool * constr_expr) -> ?generalize:bool - -> ?tac:unit Proofview.tactic -> ?hook:(GlobRef.t -> unit) -> Hints.hint_info_expr -> Id.t @@ -64,7 +63,6 @@ val new_instance_program : -> constr_expr -> (bool * constr_expr) option -> ?generalize:bool - -> ?tac:unit Proofview.tactic -> ?hook:(GlobRef.t -> unit) -> Hints.hint_info_expr -> Id.t diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 2165f7c3ef..ca4b50318b 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -64,6 +64,16 @@ let modify_pstate ~pstate f = vernac_require_open_proof ~pstate (fun ~pstate -> Some (Proof_global.modify_current_pstate (fun pstate -> f ~pstate) pstate)) +let with_read_proof ~pstate f = + f ~pstate; + pstate + +let with_open_proof ~pstate f = + Some (Proof_global.push ~ontop:pstate (f ~pstate)) + +let with_open_proof_simple ~pstate f = + Some (Proof_global.push ~ontop:pstate f) + let get_current_or_global_context ~pstate = match pstate with | None -> let env = Global.env () in Evd.(from_env env, env) @@ -99,6 +109,25 @@ module DefAttributes = struct { polymorphic; program; locality; deprecated } end +let with_locality ~atts f = + let local = Attributes.(parse locality atts) in + f ~local + +let with_section_locality ~atts f = + let local = Attributes.(parse locality atts) in + let section_local = make_section_locality local in + f ~section_local + +let with_module_locality ~atts f = + let local = Attributes.(parse locality atts) in + let module_local = make_module_locality local in + f ~module_local + +let with_def_attributes ~atts f = + let atts = DefAttributes.parse atts in + if atts.DefAttributes.program then Obligations.check_program_libraries (); + f ~atts + (*******************) (* "Show" commands *) @@ -1085,37 +1114,33 @@ let vernac_identity_coercion ~atts id qids qidt = (* Type classes *) -let vernac_instance_interactive ~atts name bl t pri = - let open DefAttributes in +let vernac_instance ~pstate ~atts name bl t props info = Dumpglob.dump_constraint (fst name) false "inst"; - let global = not (make_section_locality atts.locality) in - let _id, pstate = - Classes.new_instance_interactive - ~global atts.polymorphic name bl t pri in - pstate - -let vernac_instance_program ~atts name bl t opt_props pri = - let open DefAttributes in - Dumpglob.dump_constraint (fst name) false "inst"; - let global = not (make_section_locality atts.locality) in - let _id = Classes.new_instance_program - ~global atts.polymorphic name bl t opt_props pri in - () - -let vernac_instance ~atts name bl t props pri = - let open DefAttributes in - Dumpglob.dump_constraint (fst name) false "inst"; - let global = not (make_section_locality atts.locality) in - let _id = - Classes.new_instance - ~global atts.polymorphic name bl t props pri in - () + let (program, locality), polymorphic = + Attributes.(parse (Notations.(program ++ locality ++ polymorphic))) atts + in + let global = not (make_section_locality locality) in + if program then begin + let _id : Id.t = Classes.new_instance_program ~global polymorphic name bl t props info in + pstate + end else begin + match props with + | None -> + with_open_proof_simple ~pstate + (let _id, pstate = Classes.new_instance_interactive ~global polymorphic name bl t info in + pstate) + | Some props -> + let _id : Id.t = Classes.new_instance ~global polymorphic name bl t props info in + pstate + end let vernac_declare_instance ~atts id bl inst pri = - let open DefAttributes in Dumpglob.dump_definition (fst id) false "inst"; - let global = not (make_section_locality atts.locality) in - Classes.declare_new_instance ~program_mode:atts.program ~global atts.polymorphic id bl inst pri + let (program, locality), polymorphic = + Attributes.(parse (Notations.(program ++ locality ++ polymorphic))) atts + in + let global = not (make_section_locality locality) in + Classes.declare_new_instance ~program_mode:program ~global polymorphic id bl inst pri let vernac_context ~poly l = if not (ComAssumption.context poly l) then Feedback.feedback Feedback.AddedAxiom @@ -2253,36 +2278,6 @@ let vernac_check_guard ~pstate = (str ("Condition violated: ") ++s) in message -(* Attributes *) -let with_locality ~atts f = - let local = Attributes.(parse locality atts) in - f ~local - -let with_section_locality ~atts f = - let local = Attributes.(parse locality atts) in - let section_local = make_section_locality local in - f ~section_local - -let with_module_locality ~atts f = - let local = Attributes.(parse locality atts) in - let module_local = make_module_locality local in - f ~module_local - -let with_def_attributes ~atts f = - let atts = DefAttributes.parse atts in - if atts.DefAttributes.program then Obligations.check_program_libraries (); - f ~atts - -let with_read_proof ~pstate f = - f ~pstate; - pstate - -let with_open_proof ~pstate f = - Some (Proof_global.push ~ontop:pstate (f ~pstate)) - -let with_open_proof_simple ~pstate f = - Some (Proof_global.push ~ontop:pstate f) - (** A global default timeout, controlled by option "Set Default Timeout n". Use "Unset Default Timeout" to deactivate it (or set it to 0). *) @@ -2517,22 +2512,9 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.stack option = (* Type classes *) | VernacInstance (name, bl, t, props, info) -> - if (DefAttributes.parse atts).DefAttributes.program then begin - with_def_attributes ~atts - (vernac_instance_program name bl t props info); - pstate - end else begin - match props with - | None -> - with_open_proof_simple ~pstate - (with_def_attributes ~atts - (vernac_instance_interactive name bl t info)) - | Some props -> - with_def_attributes ~atts (vernac_instance name bl t props info); - pstate - end + vernac_instance ~pstate ~atts name bl t props info | VernacDeclareInstance (id, bl, inst, info) -> - with_def_attributes ~atts vernac_declare_instance id bl inst info; + vernac_declare_instance ~atts id bl inst info; pstate | VernacContext sup -> let () = vernac_context ~poly:(only_polymorphism atts) sup in -- cgit v1.2.3 From 4131b14ac8ea93b54583c0c6fc0dff310a9c5172 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 28 May 2019 22:20:03 +0200 Subject: Fix typo in changelog --- .../02-specification-language/10215-rm-maybe-open-proof.rst | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst b/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst index 12d458a72c..21ec7f8e5b 100644 --- a/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst +++ b/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst @@ -1,7 +1,6 @@ - Function always opens a proof when used with a ``measure`` or ``wf`` - annotation, see Description of the changes, with possible link to - :ref:`advanced-recursive-functions` of the updated documentation - (`#10215 `_, + annotation, see :ref:`advanced-recursive-functions` for the updated + documentation (`#10215 `_, by Enrico Tassi). - The legacy command Add Morphism always opens a proof and cannot be used -- cgit v1.2.3 From ae87619019adf56acf8985f7f1c4e49246ca9b5a Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 21 May 2019 21:55:46 +0200 Subject: [vernac] Interpret regular vernacs symbolically This provides uniformity to the inner loop and prepares the way to export a refined type for interpretation. The only non-uniformity remaining is the one due to the `?proof` parameter; it won't be easy to fix due to upper layers issues. Note that this step is not yet fully satisfying, as a true typed `vernac_expr` definition is still not possible because of syntactic non-uniformity, in particular all the surgery done for `CoFixpoint` and `Instance` should be eliminated in favor of more refined AST tags. An interesting TODO is to handle attributes symbolically too, as to remove boilerplate. --- vernac/lemmas.ml | 8 +- vernac/lemmas.mli | 2 +- vernac/vernacentries.ml | 646 ++++++++++++++++++++++++------------------------ vernac/vernacextend.ml | 7 +- vernac/vernacextend.mli | 7 +- 5 files changed, 338 insertions(+), 332 deletions(-) diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index d0ec575eb3..d14c7ddf8f 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -207,12 +207,8 @@ let save ?export_seff id const uctx do_guard (locality,poly,kind) hook universes let default_thm_id = Id.of_string "Unnamed_thm" -let fresh_name_for_anonymous_theorem ~pstate = - let avoid = match pstate with - | None -> Id.Set.empty - | Some pstate -> Id.Set.of_list (Proof_global.get_all_proof_names pstate) - in - next_global_ident_away default_thm_id avoid +let fresh_name_for_anonymous_theorem () = + next_global_ident_away default_thm_id Id.Set.empty let check_name_freshness locality {CAst.loc;v=id} : unit = (* We check existence here: it's a bit late at Qed time *) diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index c4c609e824..3df543156d 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -61,7 +61,7 @@ val standard_proof_terminator : ?hook:declaration_hook -> Proof_global.lemma_possible_guards -> Proof_global.proof_terminator -val fresh_name_for_anonymous_theorem : pstate:Proof_global.stack option -> Id.t +val fresh_name_for_anonymous_theorem : unit -> Id.t (* Prepare global named context for proof session: remove proofs of opaque section definitions and remove vm-compiled code *) diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index ca4b50318b..18e0fde296 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -47,10 +47,7 @@ let vernac_pperr_endline pp = let there_are_pending_proofs ~pstate = not Option.(is_empty pstate) -let check_no_pending_proof ~pstate = - if there_are_pending_proofs ~pstate then - user_err Pp.(str "Command not supported (Open proofs remain)") - +(* EJGA: Only used in close_proof 2, can remove once ?proof hack is away *) let vernac_require_open_proof ~pstate f = match pstate with | Some pstate -> f ~pstate @@ -60,19 +57,9 @@ let with_pstate ~pstate f = vernac_require_open_proof ~pstate (fun ~pstate -> f ~pstate:(Proof_global.get_current_pstate pstate)) -let modify_pstate ~pstate f = - vernac_require_open_proof ~pstate (fun ~pstate -> - Some (Proof_global.modify_current_pstate (fun pstate -> f ~pstate) pstate)) - -let with_read_proof ~pstate f = - f ~pstate; - pstate - -let with_open_proof ~pstate f = - Some (Proof_global.push ~ontop:pstate (f ~pstate)) - -let with_open_proof_simple ~pstate f = - Some (Proof_global.push ~ontop:pstate f) + let modify_pstate ~pstate f = + vernac_require_open_proof ~pstate (fun ~pstate -> + Some (Proof_global.modify_current_pstate (fun pstate -> f ~pstate) pstate)) let get_current_or_global_context ~pstate = match pstate with @@ -610,10 +597,11 @@ let vernac_definition_hook p = function Some (Class.add_subclass_hook p) | _ -> None -let vernac_definition_name lid local ~pstate = +let vernac_definition_name lid local = let lid = match lid with - | { v = Name.Anonymous; loc } -> CAst.make ?loc (fresh_name_for_anonymous_theorem ~pstate) + | { v = Name.Anonymous; loc } -> + CAst.make ?loc (fresh_name_for_anonymous_theorem ()) | { v = Name.Name n; loc } -> CAst.make ?loc n in let () = match local with @@ -622,25 +610,25 @@ let vernac_definition_name lid local ~pstate = in lid -let vernac_definition_interactive ~atts (discharge, kind) (lid, pl) bl t ~pstate = +let vernac_definition_interactive ~atts (discharge, kind) (lid, pl) bl t = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in let hook = vernac_definition_hook atts.polymorphic kind in let program_mode = atts.program in - let name = vernac_definition_name lid local ~pstate in + let name = vernac_definition_name lid local in start_proof_and_print ~program_mode (local, atts.polymorphic, DefinitionBody kind) ?hook [(name, pl), (bl, t)] -let vernac_definition ~atts (discharge, kind) (lid, pl) bl red_option c typ_opt ~pstate = +let vernac_definition ~atts (discharge, kind) (lid, pl) bl red_option c typ_opt = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in let hook = vernac_definition_hook atts.polymorphic kind in let program_mode = atts.program in - let name = vernac_definition_name lid local ~pstate in - let pstate = Option.map Proof_global.get_current_pstate pstate in + let name = vernac_definition_name lid local in let red_option = match red_option with | None -> None | Some r -> - let sigma, env = get_current_or_global_context ~pstate in + let env = Global.env () in + let sigma = Evd.from_env env in Some (snd (Hook.get f_interp_redexp env sigma r)) in ComDefinition.do_definition ~program_mode name.v (local, atts.polymorphic, kind) pl bl red_option c typ_opt ?hook @@ -660,13 +648,12 @@ let vernac_end_proof ?pstate:ontop ?proof = function | Proved (opaque,idopt) -> save_proof_proved ?ontop ?proof ~opaque ~idopt -let vernac_exact_proof ~pstate:ontop c = +let vernac_exact_proof ~pstate c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the beginning of a proof. *) - let pstate, status = Pfedit.by (Tactics.exact_proof c) (Proof_global.get_current_pstate ontop) in + let pstate, status = Pfedit.by (Tactics.exact_proof c) pstate in let () = save_pstate_proved ~pstate ~opaque:Proof_global.Opaque ~idopt:None in - if not status then Feedback.feedback Feedback.AddedAxiom; - Proof_global.discard_current ontop + if not status then Feedback.feedback Feedback.AddedAxiom let vernac_assumption ~atts discharge kind l nl = let open DefAttributes in @@ -939,14 +926,13 @@ let vernac_declare_module export {loc;v=id} binders_ast mty_ast = Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is declared"); Option.iter (fun export -> vernac_import export [qualid_of_ident id]) export -let vernac_define_module ~pstate export {loc;v=id} (binders_ast : module_binder list) mty_ast_o mexpr_ast_l = +let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mty_ast_o mexpr_ast_l = (* We check the state of the system (in section, in module type) and what module information is supplied *) if Lib.sections_are_opened () then user_err Pp.(str "Modules and Module Types are not allowed inside sections."); match mexpr_ast_l with | [] -> - check_no_pending_proof ~pstate; let binders_ast,argsexport = List.fold_right (fun (export,idl,ty) (args,argsexport) -> @@ -986,13 +972,12 @@ let vernac_end_module export {loc;v=id} = Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is defined"); Option.iter (fun export -> vernac_import export [qualid_of_ident ?loc id]) export -let vernac_declare_module_type ~pstate {loc;v=id} binders_ast mty_sign mty_ast_l = +let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = if Lib.sections_are_opened () then user_err Pp.(str "Modules and Module Types are not allowed inside sections."); match mty_ast_l with | [] -> - check_no_pending_proof ~pstate; let binders_ast,argsexport = List.fold_right (fun (export,idl,ty) (args,argsexport) -> @@ -1039,8 +1024,7 @@ let vernac_include l = (* Sections *) -let vernac_begin_section ~pstate ({v=id} as lid) = - check_no_pending_proof ~pstate; +let vernac_begin_section ({v=id} as lid) = Dumpglob.dump_definition lid true "sec"; Lib.open_section id @@ -1053,8 +1037,7 @@ let vernac_name_sec_hyp {v=id} set = Proof_using.name_set id set (* Dispatcher of the "End" command *) -let vernac_end_segment ~pstate ({v=id} as lid) = - check_no_pending_proof ~pstate; +let vernac_end_segment ({v=id} as lid) = match Lib.find_opening_node id with | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid | Lib.OpenedModule (true,_,_,_) -> vernac_end_modtype lid @@ -1114,25 +1097,34 @@ let vernac_identity_coercion ~atts id qids qidt = (* Type classes *) -let vernac_instance ~pstate ~atts name bl t props info = +let vernac_instance_program ~atts name bl t props info = Dumpglob.dump_constraint (fst name) false "inst"; let (program, locality), polymorphic = Attributes.(parse (Notations.(program ++ locality ++ polymorphic))) atts in let global = not (make_section_locality locality) in - if program then begin - let _id : Id.t = Classes.new_instance_program ~global polymorphic name bl t props info in - pstate - end else begin - match props with - | None -> - with_open_proof_simple ~pstate - (let _id, pstate = Classes.new_instance_interactive ~global polymorphic name bl t info in - pstate) - | Some props -> - let _id : Id.t = Classes.new_instance ~global polymorphic name bl t props info in - pstate - end + let _id : Id.t = Classes.new_instance_program ~global polymorphic name bl t props info in + () + +let vernac_instance_interactive ~atts name bl t info = + Dumpglob.dump_constraint (fst name) false "inst"; + let (program, locality), polymorphic = + Attributes.(parse (Notations.(program ++ locality ++ polymorphic))) atts + in + let global = not (make_section_locality locality) in + let _id, pstate = + Classes.new_instance_interactive ~global polymorphic name bl t info in + pstate + +let vernac_instance ~atts name bl t props info = + Dumpglob.dump_constraint (fst name) false "inst"; + let (program, locality), polymorphic = + Attributes.(parse (Notations.(program ++ locality ++ polymorphic))) atts + in + let global = not (make_section_locality locality) in + let _id : Id.t = + Classes.new_instance ~global polymorphic name bl t props info in + () let vernac_declare_instance ~atts id bl inst pri = Dumpglob.dump_definition (fst id) false "inst"; @@ -1898,7 +1890,6 @@ let query_command_selector ?loc = function (str "Query commands only support the single numbered goal selector.") let vernac_check_may_eval ~pstate ~atts redexp glopt rc = - let pstate = Option.map Proof_global.get_current_pstate pstate in let glopt = query_command_selector glopt in let sigma, env = get_current_context_of_args ~pstate glopt in let sigma, c = interp_open_constr env sigma rc in @@ -1998,8 +1989,7 @@ let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = let sigma, env = get_current_or_global_context ~pstate in print_about env sigma ref_or_by_not udecl -let vernac_print ~(pstate : Proof_global.stack option) ~atts = - let pstate = Option.map Proof_global.get_current_pstate pstate in +let vernac_print ~pstate ~atts = let sigma, env = get_current_or_global_context ~pstate in function | PrintTables -> print_tables () @@ -2111,7 +2101,6 @@ let () = optwrite = (:=) search_output_name_only } let vernac_search ~pstate ~atts s gopt r = - let pstate = Option.map Proof_global.get_current_pstate pstate in let gopt = query_command_selector gopt in let r = interp_search_restriction r in let env,gopt = @@ -2149,7 +2138,6 @@ let vernac_locate ~pstate = function | LocateTerm {v=AN qid} -> print_located_term qid | LocateAny {v=ByNotation (ntn, sc)} (* TODO : handle Ltac notations *) | LocateTerm {v=ByNotation (ntn, sc)} -> - let pstate = Option.map Proof_global.get_current_pstate pstate in let _, env = get_current_or_global_context ~pstate in Notation.locate_notation (Constrextern.without_symbols (pr_lglob_constr_env env)) ntn sc @@ -2158,10 +2146,8 @@ let vernac_locate ~pstate = function | LocateOther (s, qid) -> print_located_other s qid | LocateFile f -> locate_file f -let vernac_register ~pstate qid r = +let vernac_register qid r = let gr = Smartlocate.global_with_alias qid in - if there_are_pending_proofs ~pstate then - user_err Pp.(str "Cannot register a primitive while in proof editing mode."); match r with | RegisterInline -> begin match gr with @@ -2189,23 +2175,24 @@ let vernac_register ~pstate qid r = (********************) (* Proof management *) -let vernac_focus gln = - Proof_global.simple_with_current_proof (fun _ p -> +let vernac_focus ~pstate gln = + Proof_global.modify_proof (fun p -> match gln with | None -> Proof.focus focus_command_cond () 1 p | Some 0 -> user_err Pp.(str "Invalid goal number: 0. Goal numbering starts with 1.") | Some n -> Proof.focus focus_command_cond () n p) + pstate (* Unfocuses one step in the focus stack. *) -let vernac_unfocus () = - Proof_global.simple_with_current_proof - (fun _ p -> Proof.unfocus command_focus p ()) +let vernac_unfocus ~pstate = + Proof_global.modify_proof + (fun p -> Proof.unfocus command_focus p ()) + pstate (* Checks that a proof is fully unfocused. Raises an error if not. *) let vernac_unfocused ~pstate = - let pstate = Proof_global.get_current_pstate pstate in let p = Proof_global.give_me_the_proof pstate in if Proof.unfocused p then str"The proof is indeed fully unfocused." @@ -2219,25 +2206,29 @@ let vernac_unfocused ~pstate = let subproof_kind = Proof.new_focus_kind () let subproof_cond = Proof.done_cond subproof_kind -let vernac_subproof gln = - Proof_global.simple_with_current_proof (fun _ p -> +let vernac_subproof gln ~pstate = + Proof_global.modify_proof (fun p -> match gln with | None -> Proof.focus subproof_cond () 1 p | Some (Goal_select.SelectNth n) -> Proof.focus subproof_cond () n p | Some (Goal_select.SelectId id) -> Proof.focus_id subproof_cond () id p | _ -> user_err ~hdr:"bracket_selector" (str "Brackets do not support multi-goal selectors.")) + pstate -let vernac_end_subproof () = - Proof_global.simple_with_current_proof (fun _ p -> - Proof.unfocus subproof_kind p ()) +let vernac_end_subproof ~pstate = + Proof_global.modify_proof (fun p -> + Proof.unfocus subproof_kind p ()) + pstate -let vernac_bullet (bullet : Proof_bullet.t) = - Proof_global.simple_with_current_proof (fun _ p -> - Proof_bullet.put p bullet) +let vernac_bullet (bullet : Proof_bullet.t) ~pstate = + Proof_global.modify_proof (fun p -> + Proof_bullet.put p bullet) pstate -let vernac_show ~pstate:ontop = - match ontop with +(* Stack is needed due to show proof names, should deprecate / remove + and take pstate *) +let vernac_show ~pstate = + match pstate with (* Show functions that don't require a proof state *) | None -> begin function @@ -2247,8 +2238,7 @@ let vernac_show ~pstate:ontop = user_err (str "This command requires an open proof.") end (* Show functions that require a proof state *) - | Some ontop -> - let pstate = Proof_global.get_current_pstate ontop in + | Some pstate -> begin function | ShowGoal goalref -> let proof = Proof_global.give_me_the_proof pstate in @@ -2260,7 +2250,7 @@ let vernac_show ~pstate:ontop = | ShowExistentials -> show_top_evars ~pstate | ShowUniverses -> show_universes ~pstate | ShowProofNames -> - pr_sequence Id.print (Proof_global.get_all_proof_names ontop) + Id.print (Proof_global.get_current_proof_name pstate) | ShowIntros all -> show_intro ~pstate all | ShowProof -> show_proof ~pstate:(Some pstate) | ShowMatch id -> show_match id @@ -2332,11 +2322,16 @@ let locate_if_not_already ?loc (e, info) = exception End_of_input -let vernac_interp_phase c ~pstate = +let interp_typed_vernac c ~pstate = let open Proof_global in let open Vernacextend in match c with | VtDefault f -> f (); pstate + | VtNoProof f -> + if there_are_pending_proofs ~pstate then + user_err Pp.(str "Command not supported (Open proofs remain)"); + let () = f () in + pstate | VtCloseProof f -> vernac_require_open_proof ~pstate (fun ~pstate -> f ~pstate:(Proof_global.get_current_pstate pstate); @@ -2352,350 +2347,363 @@ let vernac_interp_phase c ~pstate = with_pstate ~pstate f; pstate -(* "locality" is the prefix "Local" attribute, while the "local" component - * is the outdated/deprecated "Local" attribute of some vernacular commands - * still parsed as the obsolete_locality grammar entry for retrocompatibility. - * loc is the Loc.t of the vernacular command being interpreted. *) -let rec interp_expr ?proof ~atts ~st c : Proof_global.stack option = - let pstate = st.Vernacstate.proof in - vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); - match c with - - (* The STM should handle that, but LOAD bypasses the STM... *) - | VernacAbortAll -> CErrors.user_err (str "AbortAll cannot be used through the Load command") - | VernacRestart -> CErrors.user_err (str "Restart cannot be used through the Load command") - | VernacUndo _ -> CErrors.user_err (str "Undo cannot be used through the Load command") - | VernacUndoTo _ -> CErrors.user_err (str "UndoTo cannot be used through the Load command") - - (* Resetting *) - | VernacResetName _ -> anomaly (str "VernacResetName not handled by Stm.") - | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm.") - | VernacBack _ -> anomaly (str "VernacBack not handled by Stm.") - | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm.") - - (* This one is possible to handle here *) - | VernacAbort id -> CErrors.user_err (str "Abort cannot be used through the Load command") - - (* Loading a file requires access to the control interpreter so - [vernac_load] is mutually-recursive with [interp_expr] *) - | VernacLoad (verbosely,fname) -> - unsupported_attributes atts; - vernac_load ?proof ~verbosely ~st fname - +(* We interpret vernacular commands to a DSL that specifies their + allowed actions on proof states *) +let translate_vernac ~atts v = let open Vernacextend in match v with + | VernacEndProof _ + | VernacAbortAll + | VernacRestart + | VernacUndo _ + | VernacUndoTo _ + | VernacResetName _ + | VernacResetInitial + | VernacBack _ + | VernacBackTo _ + | VernacAbort _ + | VernacLoad _ -> + anomaly (str "type_vernac") (* Syntax *) | VernacSyntaxExtension (infix, sl) -> - with_module_locality ~atts vernac_syntax_extension infix sl; - pstate + VtDefault(fun () -> with_module_locality ~atts vernac_syntax_extension infix sl) | VernacDeclareScope sc -> - with_module_locality ~atts vernac_declare_scope sc; - pstate + VtDefault(fun () -> with_module_locality ~atts vernac_declare_scope sc) | VernacDelimiters (sc,lr) -> - with_module_locality ~atts vernac_delimiters sc lr; - pstate + VtDefault(fun () -> with_module_locality ~atts vernac_delimiters sc lr) | VernacBindScope (sc,rl) -> - with_module_locality ~atts vernac_bind_scope sc rl; - pstate + VtDefault(fun () -> with_module_locality ~atts vernac_bind_scope sc rl) | VernacOpenCloseScope (b, s) -> - with_section_locality ~atts vernac_open_close_scope (b,s); - pstate + VtDefault(fun () -> with_section_locality ~atts vernac_open_close_scope (b,s)) | VernacInfix (mv,qid,sc) -> - with_module_locality ~atts vernac_infix mv qid sc; - pstate + VtDefault(fun () -> with_module_locality ~atts vernac_infix mv qid sc) | VernacNotation (c,infpl,sc) -> - with_module_locality ~atts vernac_notation c infpl sc; - pstate + VtDefault(fun () -> with_module_locality ~atts vernac_notation c infpl sc) | VernacNotationAddFormat(n,k,v) -> - unsupported_attributes atts; - Metasyntax.add_notation_extra_printing_rule n k v; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + Metasyntax.add_notation_extra_printing_rule n k v) | VernacDeclareCustomEntry s -> - with_module_locality ~atts vernac_custom_entry s; - pstate + VtDefault(fun () -> with_module_locality ~atts vernac_custom_entry s) (* Gallina *) - | VernacDefinition (dk,lid,ProveBody(bl,t)) -> - with_open_proof ~pstate (with_def_attributes ~atts vernac_definition_interactive dk lid bl t) - | VernacDefinition (dk,lid,DefineBody(bl,red_option,c,typ_opt)) -> - with_read_proof ~pstate (with_def_attributes ~atts vernac_definition dk lid bl red_option c typ_opt) + + | VernacDefinition (discharge,lid,DefineBody (bl,red_option,c,typ)) -> + VtDefault (fun () -> + with_def_attributes ~atts + vernac_definition discharge lid bl red_option c typ) + | VernacDefinition (discharge,lid,ProveBody(bl,typ)) -> + VtOpenProof(fun () -> + with_def_attributes ~atts + vernac_definition_interactive discharge lid bl typ) + | VernacStartTheoremProof (k,l) -> - with_open_proof_simple ~pstate (with_def_attributes ~atts vernac_start_proof k l) - | VernacEndProof e -> - unsupported_attributes atts; - vernac_end_proof ?proof ?pstate e + VtOpenProof(fun () -> with_def_attributes ~atts vernac_start_proof k l) | VernacExactProof c -> - unsupported_attributes atts; - vernac_require_open_proof ~pstate (vernac_exact_proof c) + VtCloseProof(fun ~pstate -> + unsupported_attributes atts; + vernac_exact_proof ~pstate c) + + | VernacDefineModule (export,lid,bl,mtys,mexprl) -> + let i () = + unsupported_attributes atts; + vernac_define_module export lid bl mtys mexprl in + (* XXX: We should investigate if eventually this should be made + VtNoProof in all cases. *) + if List.is_empty mexprl then VtNoProof i else VtDefault i + + | VernacDeclareModuleType (lid,bl,mtys,mtyo) -> + VtNoProof(fun () -> + unsupported_attributes atts; + vernac_declare_module_type lid bl mtys mtyo) | VernacAssumption ((discharge,kind),nl,l) -> - with_def_attributes ~atts vernac_assumption discharge kind l nl; - pstate + VtDefault(fun () -> with_def_attributes ~atts vernac_assumption discharge kind l nl) | VernacInductive (cum, priv, finite, l) -> - vernac_inductive ~atts cum priv finite l; - pstate + VtDefault(fun () -> vernac_inductive ~atts cum priv finite l) | VernacFixpoint (discharge, l) -> let opens = List.exists (fun ((_,_,_,_,p),_) -> Option.is_empty p) l in if opens then - with_open_proof_simple ~pstate (with_def_attributes ~atts vernac_fixpoint_interactive discharge l) + VtOpenProof (fun () -> + with_def_attributes ~atts vernac_fixpoint_interactive discharge l) else - (with_def_attributes ~atts vernac_fixpoint discharge l; pstate) + VtDefault (fun () -> + with_def_attributes ~atts vernac_fixpoint discharge l) | VernacCoFixpoint (discharge, l) -> let opens = List.exists (fun ((_,_,_,p),_) -> Option.is_empty p) l in if opens then - with_open_proof_simple ~pstate (with_def_attributes ~atts vernac_cofixpoint_interactive discharge l) + VtOpenProof(fun () -> with_def_attributes ~atts vernac_cofixpoint_interactive discharge l) else - (with_def_attributes ~atts vernac_cofixpoint discharge l; pstate) + VtDefault(fun () -> with_def_attributes ~atts vernac_cofixpoint discharge l) + | VernacScheme l -> - unsupported_attributes atts; - vernac_scheme l; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_scheme l) | VernacCombinedScheme (id, l) -> - unsupported_attributes atts; - vernac_combined_scheme id l; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_combined_scheme id l) | VernacUniverse l -> - vernac_universe ~poly:(only_polymorphism atts) l; - pstate + VtDefault(fun () -> vernac_universe ~poly:(only_polymorphism atts) l) | VernacConstraint l -> - vernac_constraint ~poly:(only_polymorphism atts) l; - pstate + VtDefault(fun () -> vernac_constraint ~poly:(only_polymorphism atts) l) (* Modules *) | VernacDeclareModule (export,lid,bl,mtyo) -> - unsupported_attributes atts; - vernac_declare_module export lid bl mtyo; - pstate - | VernacDefineModule (export,lid,bl,mtys,mexprl) -> - unsupported_attributes atts; - vernac_define_module ~pstate export lid bl mtys mexprl; - pstate - | VernacDeclareModuleType (lid,bl,mtys,mtyo) -> - unsupported_attributes atts; - vernac_declare_module_type ~pstate lid bl mtys mtyo; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_declare_module export lid bl mtyo) | VernacInclude in_asts -> - unsupported_attributes atts; - vernac_include in_asts; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_include in_asts) (* Gallina extensions *) | VernacBeginSection lid -> - unsupported_attributes atts; - vernac_begin_section ~pstate lid; - pstate - + VtNoProof(fun () -> + unsupported_attributes atts; + vernac_begin_section lid) | VernacEndSegment lid -> - unsupported_attributes atts; - vernac_end_segment ~pstate lid; - pstate - + VtNoProof(fun () -> + unsupported_attributes atts; + vernac_end_segment lid) | VernacNameSectionHypSet (lid, set) -> - unsupported_attributes atts; - vernac_name_sec_hyp lid set; - pstate - + VtDefault(fun () -> + unsupported_attributes atts; + vernac_name_sec_hyp lid set) | VernacRequire (from, export, qidl) -> - unsupported_attributes atts; - vernac_require from export qidl; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_require from export qidl) | VernacImport (export,qidl) -> - unsupported_attributes atts; - vernac_import export qidl; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_import export qidl) | VernacCanonical qid -> - unsupported_attributes atts; - vernac_canonical qid; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_canonical qid) | VernacCoercion (r,s,t) -> - vernac_coercion ~atts r s t; - pstate + VtDefault(fun () -> vernac_coercion ~atts r s t) | VernacIdentityCoercion ({v=id},s,t) -> - vernac_identity_coercion ~atts id s t; - pstate + VtDefault(fun () -> vernac_identity_coercion ~atts id s t) (* Type classes *) | VernacInstance (name, bl, t, props, info) -> - vernac_instance ~pstate ~atts name bl t props info + let { DefAttributes.program } = DefAttributes.parse atts in + if program then + VtDefault (fun () -> vernac_instance_program ~atts name bl t props info) + else begin match props with + | None -> + VtOpenProof(fun () -> + vernac_instance_interactive ~atts name bl t info) + | Some props -> + VtDefault(fun () -> + vernac_instance ~atts name bl t props info) + end + | VernacDeclareInstance (id, bl, inst, info) -> - vernac_declare_instance ~atts id bl inst info; - pstate + VtDefault(fun () -> vernac_declare_instance ~atts id bl inst info) | VernacContext sup -> - let () = vernac_context ~poly:(only_polymorphism atts) sup in - pstate + VtDefault(fun () -> vernac_context ~poly:(only_polymorphism atts) sup) | VernacExistingInstance insts -> - with_section_locality ~atts vernac_existing_instance insts; - pstate + VtDefault(fun () -> with_section_locality ~atts vernac_existing_instance insts) | VernacExistingClass id -> - unsupported_attributes atts; - vernac_existing_class id; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_existing_class id) (* Solving *) | VernacSolveExistential (n,c) -> - unsupported_attributes atts; - modify_pstate ~pstate (vernac_solve_existential n c) - + VtModifyProof(fun ~pstate -> + unsupported_attributes atts; + vernac_solve_existential ~pstate n c) (* Auxiliary file and library management *) | VernacAddLoadPath (isrec,s,alias) -> - unsupported_attributes atts; - vernac_add_loadpath isrec s alias; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_add_loadpath isrec s alias) | VernacRemoveLoadPath s -> - unsupported_attributes atts; - vernac_remove_loadpath s; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_remove_loadpath s) | VernacAddMLPath (isrec,s) -> - unsupported_attributes atts; - vernac_add_ml_path isrec s; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_add_ml_path isrec s) | VernacDeclareMLModule l -> - with_locality ~atts vernac_declare_ml_module l; - pstate + VtDefault(fun () -> with_locality ~atts vernac_declare_ml_module l) | VernacChdir s -> - unsupported_attributes atts; - vernac_chdir s; - pstate + VtDefault(fun () -> unsupported_attributes atts; vernac_chdir s) (* State management *) | VernacWriteState s -> - unsupported_attributes atts; - vernac_write_state s; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_write_state s) | VernacRestoreState s -> - unsupported_attributes atts; - vernac_restore_state s; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_restore_state s) (* Commands *) | VernacCreateHintDb (dbname,b) -> - with_module_locality ~atts vernac_create_hintdb dbname b; - pstate + VtDefault(fun () -> + with_module_locality ~atts vernac_create_hintdb dbname b) | VernacRemoveHints (dbnames,ids) -> - with_module_locality ~atts vernac_remove_hints dbnames ids; - pstate + VtDefault(fun () -> + with_module_locality ~atts vernac_remove_hints dbnames ids) | VernacHints (dbnames,hints) -> - vernac_hints ~atts dbnames hints; - pstate + VtDefault(fun () -> + vernac_hints ~atts dbnames hints) | VernacSyntacticDefinition (id,c,b) -> - with_module_locality ~atts vernac_syntactic_definition id c b; - pstate - | VernacArguments (qid, args, more_implicits, nargs, nargs_before_bidi, flags) -> - with_section_locality ~atts vernac_arguments qid args more_implicits nargs nargs_before_bidi flags; - pstate + VtDefault(fun () -> + with_module_locality ~atts vernac_syntactic_definition id c b) + | VernacArguments (qid, args, more_implicits, nargs, bidi, flags) -> + VtDefault(fun () -> + with_section_locality ~atts (vernac_arguments qid args more_implicits nargs bidi flags)) | VernacReserve bl -> - unsupported_attributes atts; - vernac_reserve bl; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_reserve bl) | VernacGeneralizable gen -> - with_locality ~atts vernac_generalizable gen; - pstate + VtDefault(fun () -> with_locality ~atts vernac_generalizable gen) | VernacSetOpacity qidl -> - with_locality ~atts vernac_set_opacity qidl; - pstate + VtDefault(fun () -> with_locality ~atts vernac_set_opacity qidl) | VernacSetStrategy l -> - with_locality ~atts vernac_set_strategy l; - pstate + VtDefault(fun () -> with_locality ~atts vernac_set_strategy l) | VernacSetOption (export, key,v) -> - vernac_set_option ~local:(only_locality atts) export key v; - pstate + VtDefault(fun () -> + vernac_set_option ~local:(only_locality atts) export key v) | VernacRemoveOption (key,v) -> - unsupported_attributes atts; - vernac_remove_option key v; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_remove_option key v) | VernacAddOption (key,v) -> - unsupported_attributes atts; - vernac_add_option key v; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_add_option key v) | VernacMemOption (key,v) -> - unsupported_attributes atts; - vernac_mem_option key v; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_mem_option key v) | VernacPrintOption key -> - unsupported_attributes atts; - vernac_print_option key; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + vernac_print_option key) | VernacCheckMayEval (r,g,c) -> - Feedback.msg_notice @@ - vernac_check_may_eval ~pstate ~atts r g c; - pstate + VtReadProofOpt(fun ~pstate -> + Feedback.msg_notice @@ + vernac_check_may_eval ~pstate ~atts r g c) | VernacDeclareReduction (s,r) -> - with_locality ~atts vernac_declare_reduction s r; - pstate + VtDefault(fun () -> + with_locality ~atts vernac_declare_reduction s r) | VernacGlobalCheck c -> - unsupported_attributes atts; - Feedback.msg_notice @@ vernac_global_check c; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + Feedback.msg_notice @@ vernac_global_check c) | VernacPrint p -> - Feedback.msg_notice @@ vernac_print ~pstate ~atts p; - pstate + VtReadProofOpt(fun ~pstate -> + Feedback.msg_notice @@ vernac_print ~pstate ~atts p) | VernacSearch (s,g,r) -> - unsupported_attributes atts; - vernac_search ~pstate ~atts s g r; - pstate + VtReadProofOpt( + unsupported_attributes atts; + vernac_search ~atts s g r) | VernacLocate l -> unsupported_attributes atts; - Feedback.msg_notice @@ vernac_locate ~pstate l; - pstate + VtReadProofOpt(fun ~pstate -> + Feedback.msg_notice @@ vernac_locate ~pstate l) | VernacRegister (qid, r) -> - unsupported_attributes atts; - vernac_register ~pstate qid r; - pstate + VtNoProof(fun () -> + unsupported_attributes atts; + vernac_register qid r) | VernacPrimitive (id, prim, typopt) -> - unsupported_attributes atts; - ComAssumption.do_primitive id prim typopt; - pstate + VtDefault(fun () -> + unsupported_attributes atts; + ComAssumption.do_primitive id prim typopt) | VernacComments l -> - unsupported_attributes atts; - Flags.if_verbose Feedback.msg_info (str "Comments ok\n"); - pstate - + VtDefault(fun () -> + unsupported_attributes atts; + Flags.if_verbose Feedback.msg_info (str "Comments ok\n")) (* Proof management *) | VernacFocus n -> - unsupported_attributes atts; - Option.map (vernac_focus n) pstate + VtModifyProof(unsupported_attributes atts;vernac_focus n) | VernacUnfocus -> - unsupported_attributes atts; - Option.map (vernac_unfocus ()) pstate + VtModifyProof(unsupported_attributes atts;vernac_unfocus) | VernacUnfocused -> - unsupported_attributes atts; - Option.iter (fun pstate -> Feedback.msg_notice @@ vernac_unfocused ~pstate) pstate; - pstate + VtReadProof(fun ~pstate -> + unsupported_attributes atts; + Feedback.msg_notice @@ vernac_unfocused ~pstate) | VernacBullet b -> - unsupported_attributes atts; - Option.map (vernac_bullet b) pstate + VtModifyProof( + unsupported_attributes atts; + vernac_bullet b) | VernacSubproof n -> - unsupported_attributes atts; - Option.map (vernac_subproof n) pstate + VtModifyProof( + unsupported_attributes atts; + vernac_subproof n) | VernacEndSubproof -> - unsupported_attributes atts; - Option.map (vernac_end_subproof ()) pstate + VtModifyProof( + unsupported_attributes atts; + vernac_end_subproof) | VernacShow s -> - unsupported_attributes atts; - Feedback.msg_notice @@ vernac_show ~pstate s; - pstate + VtReadProofOpt(fun ~pstate -> + unsupported_attributes atts; + Feedback.msg_notice @@ vernac_show ~pstate s) | VernacCheckGuard -> - unsupported_attributes atts; - Feedback.msg_notice @@ - with_pstate ~pstate (vernac_check_guard); - pstate + VtReadProof(fun ~pstate -> + unsupported_attributes atts; + Feedback.msg_notice @@ vernac_check_guard ~pstate) | VernacProof (tac, using) -> + VtModifyProof(fun ~pstate -> unsupported_attributes atts; let using = Option.append using (Proof_using.get_default_proof_using ()) in let tacs = if Option.is_empty tac then "tac:no" else "tac:yes" in let usings = if Option.is_empty using then "using:no" else "using:yes" in Aux_file.record_in_aux_at "VernacProof" (tacs^" "^usings); - let pstate = - vernac_require_open_proof ~pstate (fun ~pstate:ontop -> - Proof_global.modify_current_pstate (fun pstate -> - let pstate = Proof_global.get_current_pstate ontop in - let pstate = Option.cata (vernac_set_end_tac ~pstate) pstate tac in - Option.cata (vernac_set_used_variables ~pstate) pstate using) - ontop) - in - Some pstate + let pstate = Option.cata (vernac_set_end_tac ~pstate) pstate tac in + Option.cata (vernac_set_used_variables ~pstate) pstate using) | VernacProofMode mn -> - unsupported_attributes atts; - pstate + VtDefault(fun () -> unsupported_attributes atts) (* Extensions *) | VernacExtend (opn,args) -> - vernac_interp_phase (Vernacextend.call ~atts opn args) ~pstate + Vernacextend.type_vernac ~atts opn args + +(* "locality" is the prefix "Local" attribute, while the "local" component + * is the outdated/deprecated "Local" attribute of some vernacular commands + * still parsed as the obsolete_locality grammar entry for retrocompatibility. + * loc is the Loc.t of the vernacular command being interpreted. *) +let rec interp_expr ?proof ~atts ~st c = + let pstate = st.Vernacstate.proof in + vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); + match c with + + (* The STM should handle that, but LOAD bypasses the STM... *) + | VernacAbortAll -> CErrors.user_err (str "AbortAll cannot be used through the Load command") + | VernacRestart -> CErrors.user_err (str "Restart cannot be used through the Load command") + | VernacUndo _ -> CErrors.user_err (str "Undo cannot be used through the Load command") + | VernacUndoTo _ -> CErrors.user_err (str "UndoTo cannot be used through the Load command") + + (* Resetting *) + | VernacResetName _ -> anomaly (str "VernacResetName not handled by Stm.") + | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm.") + | VernacBack _ -> anomaly (str "VernacBack not handled by Stm.") + | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm.") + + (* This one is possible to handle here *) + | VernacAbort id -> CErrors.user_err (str "Abort cannot be used through the Load command") + + (* Loading a file requires access to the control interpreter so + [vernac_load] is mutually-recursive with [interp_expr] *) + | VernacLoad (verbosely,fname) -> + unsupported_attributes atts; + vernac_load ?proof ~verbosely ~st fname + + (* Special: ?proof parameter doesn't allow for uniform pstate pop :S *) + | VernacEndProof e -> + unsupported_attributes atts; + vernac_end_proof ?proof ?pstate e + + | v -> + let fv = translate_vernac ~atts v in + interp_typed_vernac ~pstate fv (* XXX: This won't properly set the proof mode, as of today, it is controlled by the STM. Thus, we would need access information from diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 2d3443d30a..6f8a4e8a3c 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -53,15 +53,16 @@ type vernac_when = | VtLater type vernac_classification = vernac_type * vernac_when -type vernac_interp_phase = +type typed_vernac = | VtDefault of (unit -> unit) + | VtNoProof of (unit -> unit) | VtCloseProof of (pstate:Proof_global.t -> unit) | VtOpenProof of (unit -> Proof_global.t) | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) | VtReadProofOpt of (pstate:Proof_global.t option -> unit) | VtReadProof of (pstate:Proof_global.t -> unit) -type vernac_command = atts:Attributes.vernac_flags -> vernac_interp_phase +type vernac_command = atts:Attributes.vernac_flags -> typed_vernac type plugin_args = Genarg.raw_generic_argument list @@ -91,7 +92,7 @@ let warn_deprecated_command = (* Interpretation of a vernac command *) -let call opn converted_args ~atts = +let type_vernac opn converted_args ~atts = let phase = ref "Looking up command" in try let depr, callback = vinterp_map opn in diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index f06f31d45b..60e371a6d9 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -71,19 +71,20 @@ type vernac_classification = vernac_type * vernac_when (** Interpretation of extended vernac phrases. *) -type vernac_interp_phase = +type typed_vernac = | VtDefault of (unit -> unit) + | VtNoProof of (unit -> unit) | VtCloseProof of (pstate:Proof_global.t -> unit) | VtOpenProof of (unit -> Proof_global.t) | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) | VtReadProofOpt of (pstate:Proof_global.t option -> unit) | VtReadProof of (pstate:Proof_global.t -> unit) -type vernac_command = atts:Attributes.vernac_flags -> vernac_interp_phase +type vernac_command = atts:Attributes.vernac_flags -> typed_vernac type plugin_args = Genarg.raw_generic_argument list -val call : Vernacexpr.extend_name -> plugin_args -> vernac_command +val type_vernac : Vernacexpr.extend_name -> plugin_args -> vernac_command (** {5 VERNAC EXTEND} *) -- cgit v1.2.3